HaRe 0.7.2.8 → 0.8.0.0

raw patch · 405 files changed

+20914/−9213 lines, 405 filesdep +Cabaldep +cabal-helperdep +ghc-exactprintdep −dual-treedep −haskell-token-utilsdep ~HaRedep ~basedep ~ghcPVP ok

version bump matches the API change (PVP)

Dependencies added: Cabal, cabal-helper, ghc-exactprint, monad-control, transformers-base

Dependencies removed: dual-tree, haskell-token-utils

Dependency ranges changed: HaRe, base, ghc, ghc-mod

API changes (from Hackage documentation)

Files

• ChangeLog +8/−4
• HaRe.cabal +163/−39
• configure.sh +14/−0
• elisp/hare.el +20/−1
• src/Language/Haskell/Refact/API.hs +64/−202
• src/Language/Haskell/Refact/HaRe.hs +6/−4
• src/Language/Haskell/Refact/Refactoring/Case.hs +90/−174
• src/Language/Haskell/Refact/Refactoring/DupDef.hs +171/−113
• src/Language/Haskell/Refact/Refactoring/MoveDef.hs +1652/−1797
• src/Language/Haskell/Refact/Refactoring/Renaming.hs +81/−98
• src/Language/Haskell/Refact/Refactoring/RoundTrip.hs +23/−0
• src/Language/Haskell/Refact/Refactoring/Simple.hs +56/−0
• src/Language/Haskell/Refact/Refactoring/SwapArgs.hs +58/−38
• src/Language/Haskell/Refact/Utils/Binds.hs +164/−163
• src/Language/Haskell/Refact/Utils/ExactPrint.hs +73/−0
• src/Language/Haskell/Refact/Utils/GhcBugWorkArounds.hs +3/−19
• src/Language/Haskell/Refact/Utils/GhcModuleGraph.hs +10/−4
• src/Language/Haskell/Refact/Utils/GhcUtils.hs +37/−117
• src/Language/Haskell/Refact/Utils/GhcVersionSpecific.hs +16/−60
• src/Language/Haskell/Refact/Utils/LocUtils.hs +35/−941
• src/Language/Haskell/Refact/Utils/Monad.hs +154/−241
• src/Language/Haskell/Refact/Utils/MonadFunctions.hs +402/−317
• src/Language/Haskell/Refact/Utils/TokenUtils.hs +0/−250
• src/Language/Haskell/Refact/Utils/TypeSyn.hs +12/−13
• src/Language/Haskell/Refact/Utils/TypeUtils.hs +2286/−4275
• src/Language/Haskell/Refact/Utils/Types.hs +56/−0
• src/Language/Haskell/Refact/Utils/Utils.hs +199/−297
• src/Language/Haskell/Refact/Utils/Variables.hs +2558/−0
• src/MainHaRe.hs +27/−46
• test/CaseSpec.hs +104/−0
• test/DupDefSpec.hs +130/−0
• test/GhcUtilsSpec.hs +94/−0
• test/LocUtilsSpec.hs +62/−0
• test/MonadFunctionsSpec.hs +35/−0
• test/MoveDefSpec.hs +821/−0
• test/RenamingSpec.hs +602/−0
• test/RoundTripSpec.hs +62/−0
• test/SimpleSpec.hs +25/−0
• test/SwapArgsSpec.hs +47/−0
• test/TestUtils.hs +394/−0
• test/TypeUtilsSpec.hs +3807/−0
• test/UtilsSpec.hs +564/−0
• test/testdata/AddParams1.hs +7/−0
• test/testdata/B.hs +7/−0
• test/testdata/BCpp.hs +13/−0
• test/testdata/C.hs +5/−0
• test/testdata/Case/B.hs +19/−0
• test/testdata/Case/B.hs.expected +21/−0
• test/testdata/Case/B.hs.expected.dd +23/−0
• test/testdata/Case/BSimple.hs +5/−0
• test/testdata/Case/BSimpleExpected.hs +7/−0
• test/testdata/Case/C.hs +12/−0
• test/testdata/Case/C.hs.expected +12/−0
• test/testdata/Case/CExpected.hs +12/−0
• test/testdata/Case/D.hs +14/−0
• test/testdata/Case/D.hs.expected +14/−0
• test/testdata/Case/E.hs +16/−0
• test/testdata/Case/E.hs.expected +16/−0
• test/testdata/Case/F.hs +10/−0
• test/testdata/Case/F.hs.expected +10/−0
• test/testdata/Case/FExpected.hs +10/−0
• test/testdata/Case/Foo.hs +8/−0
• test/testdata/Case/Foo.hs.expected +8/−0
• test/testdata/Case/FooExpected.hs +8/−0
• test/testdata/Cons.hs +10/−0
• test/testdata/Demote/A1.hs +8/−0
• test/testdata/Demote/A2.hs +8/−0
• test/testdata/Demote/C1.hs +10/−0
• test/testdata/Demote/C2.hs +10/−0
• test/testdata/Demote/CaseIn1.hs +18/−0
• test/testdata/Demote/CaseIn1.hs.expected +19/−0
• test/testdata/Demote/D1.hs +14/−0
• test/testdata/Demote/D1.hs.expected +14/−0
• test/testdata/Demote/D2.hs +13/−0
• test/testdata/Demote/D2.hs.expected +12/−0
• test/testdata/Demote/D3.hs +13/−0
• test/testdata/Demote/LetIn1.hs +19/−0
• test/testdata/Demote/LetIn1.hs.expected +20/−0
• test/testdata/Demote/LetIn2.hs +18/−0
• test/testdata/Demote/MultiLeg.hs +14/−0
• test/testdata/Demote/MultiLeg2.hs +14/−0
• test/testdata/Demote/MultiLeg2.hs.expected +14/−0
• test/testdata/Demote/PatBindIn1.hs +21/−0
• test/testdata/Demote/PatBindIn1.hs.expected +21/−0
• test/testdata/Demote/PatBindIn4.hs +21/−0
• test/testdata/Demote/UsedAtLevel.expected.hs +31/−0
• test/testdata/Demote/UsedAtLevel.hs +31/−0
• test/testdata/Demote/UsedAtLevel2.expected.hs +36/−0
• test/testdata/Demote/UsedAtLevel2.hs +36/−0
• test/testdata/Demote/WhereIn1.hs +19/−0
• test/testdata/Demote/WhereIn1.hs.expected +19/−0
• test/testdata/Demote/WhereIn2.hs +20/−0
• test/testdata/Demote/WhereIn3.hs +19/−0
• test/testdata/Demote/WhereIn3.hs.expected +19/−0
• test/testdata/Demote/WhereIn4.hs +19/−0
• test/testdata/Demote/WhereIn4.hs.expected +18/−0
• test/testdata/Demote/WhereIn5.hs +18/−0
• test/testdata/Demote/WhereIn5.hs.expected +18/−0
• test/testdata/Demote/WhereIn6.hs +15/−0
• test/testdata/Demote/WhereIn6.hs.expected +15/−0
• test/testdata/Demote/WhereIn7.hs +18/−0
• test/testdata/Demote/WhereIn7.hs.expected +20/−0
• test/testdata/Demote/WhereIn8.hs +17/−0
• test/testdata/DupDef/Dd1.hs +33/−0
• test/testdata/DupDef/Dd1.hs.expected +36/−0
• test/testdata/DupDef/Dd1.hs.expected.dd +35/−0
• test/testdata/DupDef/Dd1.hs.expected.gg +36/−0
• test/testdata/DupDef/Dd1.hs.expected.ll +35/−0
• test/testdata/DupDef/Dd1.hs.expected.mm +37/−0
• test/testdata/DupDef/Dd1.hs.expected.nn +35/−0
• test/testdata/DupDef/Dd2.hs +10/−0
• test/testdata/DupDef/Dd2.hs.expected +10/−0
• test/testdata/DupDef/Dd3.hs +10/−0
• test/testdata/DupDef/Dd3.hs.expected +10/−0
• test/testdata/Exports.hs +9/−0
• test/testdata/FreeAndDeclared/Binders.hs +24/−0
• test/testdata/FreeAndDeclared/Declare.hs +37/−0
• test/testdata/FreeAndDeclared/Declare1.hs +35/−0
• test/testdata/FreeAndDeclared/Declare2.hs +35/−0
• test/testdata/FreeAndDeclared/DeclareRec.hs +12/−0
• test/testdata/FreeAndDeclared/DeclareS.hs +7/−0
• test/testdata/FreeAndDeclared/DeclareTypes.hs +32/−0
• test/testdata/Layout/Arrow.hs +46/−0
• test/testdata/Layout/Bare.hs +4/−0
• test/testdata/Layout/CaseExpr.hs +8/−0
• test/testdata/Layout/Class.hs +9/−0
• test/testdata/Layout/Comments1.hs +7/−0
• test/testdata/Layout/D5Simple.hs +7/−0
• test/testdata/Layout/Default.hs +6/−0
• test/testdata/Layout/Derive.hs +10/−0
• test/testdata/Layout/Do1.hs +13/−0
• test/testdata/Layout/Do1.hs.expected +13/−0
• test/testdata/Layout/ForAll.hs +7/−0
• test/testdata/Layout/Foreign.hs +15/−0
• test/testdata/Layout/FromMd1.hs +10/−0
• test/testdata/Layout/HsDo.hs +22/−0
• test/testdata/Layout/LetExpr.hs +8/−0
• test/testdata/Layout/LetStmt.hs +9/−0
• test/testdata/Layout/Lift.hs +7/−0
• test/testdata/Layout/Move1.hs +51/−0
• test/testdata/Layout/PArr.hs +23/−0
• test/testdata/Layout/PatBind.hs +12/−0
• test/testdata/Layout/TH.hs +10/−0
• test/testdata/Layout/Where.hs +4/−0
• test/testdata/Layout/Where2.hs +8/−0
• test/testdata/LiftOneLevel/A1.hs +7/−0
• test/testdata/LiftOneLevel/A2.hs +5/−0
• test/testdata/LiftOneLevel/A3.hs +6/−0
• test/testdata/LiftOneLevel/C1.hs +12/−0
• test/testdata/LiftOneLevel/C1.hs.expected +12/−0
• test/testdata/LiftOneLevel/C2.hs +8/−0
• test/testdata/LiftOneLevel/C2.hs.expected +8/−0
• test/testdata/LiftOneLevel/C3.hs +8/−0
• test/testdata/LiftOneLevel/CaseIn1.hs +12/−0
• test/testdata/LiftOneLevel/CaseIn1.hs.expected +13/−0
• test/testdata/LiftOneLevel/D1.hs +13/−0
• test/testdata/LiftOneLevel/D1.hs.expected +14/−0
• test/testdata/LiftOneLevel/D2.hs +12/−0
• test/testdata/LiftOneLevel/D2.hs.expected +13/−0
• test/testdata/LiftOneLevel/D3.hs +13/−0
• test/testdata/LiftOneLevel/D3.hs.expected +13/−0
• test/testdata/LiftOneLevel/LetIn1.hs +16/−0
• test/testdata/LiftOneLevel/LetIn1.hs.expected +17/−0
• test/testdata/LiftOneLevel/LetIn2.hs +17/−0
• test/testdata/LiftOneLevel/LetIn2.hs.expected +18/−0
• test/testdata/LiftOneLevel/LetIn3.hs +15/−0
• test/testdata/LiftOneLevel/LetIn3.hs.expected +16/−0
• test/testdata/LiftOneLevel/PatBindIn2.hs +17/−0
• test/testdata/LiftOneLevel/PatBindIn3.hs +15/−0
• test/testdata/LiftOneLevel/PatBindIn3.hs.expected +16/−0
• test/testdata/LiftOneLevel/WhereIn1.hs +16/−0
• test/testdata/LiftOneLevel/WhereIn1.hs.expected +17/−0
• test/testdata/LiftOneLevel/WhereIn2.hs +15/−0
• test/testdata/LiftOneLevel/WhereIn6.hs +16/−0
• test/testdata/LiftOneLevel/WhereIn6.hs.expected +17/−0
• test/testdata/LiftOneLevel/WhereIn7.hs +12/−0
• test/testdata/LiftOneLevel/WhereIn7.hs.expected +13/−0
• test/testdata/LiftOneLevel/WhereIn8.hs +9/−0
• test/testdata/LiftOneLevel/WhereIn8.hs.expected +9/−0
• test/testdata/LiftToToplevel/A1.hs +8/−0
• test/testdata/LiftToToplevel/A2.hs +6/−0
• test/testdata/LiftToToplevel/A3.hs +7/−0
• test/testdata/LiftToToplevel/C1.hs +14/−0
• test/testdata/LiftToToplevel/C1.hs.expected +14/−0
• test/testdata/LiftToToplevel/C2.hs +10/−0
• test/testdata/LiftToToplevel/C2.hs.expected +10/−0
• test/testdata/LiftToToplevel/C3.hs +10/−0
• test/testdata/LiftToToplevel/C3.hs.expected +10/−0
• test/testdata/LiftToToplevel/CaseIn1.hs +13/−0
• test/testdata/LiftToToplevel/CaseIn1.hs.expected +14/−0
• test/testdata/LiftToToplevel/D1.hs +15/−0
• test/testdata/LiftToToplevel/D1.hs.expected +16/−0
• test/testdata/LiftToToplevel/D1A.hs +16/−0
• test/testdata/LiftToToplevel/D2.hs +12/−0
• test/testdata/LiftToToplevel/D2.hs.expected +13/−0
• test/testdata/LiftToToplevel/D3.hs +13/−0
• test/testdata/LiftToToplevel/D3.hs.expected +13/−0
• test/testdata/LiftToToplevel/LetIn1.hs +16/−0
• test/testdata/LiftToToplevel/LetIn1.hs.expected +17/−0
• test/testdata/LiftToToplevel/LetIn2.hs +15/−0
• test/testdata/LiftToToplevel/LetIn2.hs.expected +16/−0
• test/testdata/LiftToToplevel/LetIn3.hs +15/−0
• test/testdata/LiftToToplevel/LetIn3.hs.expected +16/−0
• test/testdata/LiftToToplevel/LiftInLambda.expected.hs +14/−0
• test/testdata/LiftToToplevel/LiftInLambda.hs +14/−0
• test/testdata/LiftToToplevel/NoWhere.expected.hs +17/−0
• test/testdata/LiftToToplevel/NoWhere.hs +17/−0
• test/testdata/LiftToToplevel/PatBindIn1.hs +18/−0
• test/testdata/LiftToToplevel/PatBindIn1.hs.expected +18/−0
• test/testdata/LiftToToplevel/PatBindIn2.hs +17/−0
• test/testdata/LiftToToplevel/PatBindIn3.hs +16/−0
• test/testdata/LiftToToplevel/PatBindIn3.hs.expected +17/−0
• test/testdata/LiftToToplevel/Signature.expected.hs +16/−0
• test/testdata/LiftToToplevel/Signature.hs +16/−0
• test/testdata/LiftToToplevel/Signature2.hs +22/−0
• test/testdata/LiftToToplevel/Signature2r.expected.hs +19/−0
• test/testdata/LiftToToplevel/Signature2r.hs +17/−0
• test/testdata/LiftToToplevel/Signature3.expected.hs +14/−0
• test/testdata/LiftToToplevel/Signature3.hs +14/−0
• test/testdata/LiftToToplevel/Signature4.hs +14/−0
• test/testdata/LiftToToplevel/Where1.hs +28/−0
• test/testdata/LiftToToplevel/Where2.hs +22/−0
• test/testdata/LiftToToplevel/Where3.expected.hs +9/−0
• test/testdata/LiftToToplevel/Where3.hs +8/−0
• test/testdata/LiftToToplevel/WhereIn1.hs +16/−0
• test/testdata/LiftToToplevel/WhereIn1.hs.expected +17/−0
• test/testdata/LiftToToplevel/WhereIn2.hs +18/−0
• test/testdata/LiftToToplevel/WhereIn6.hs +17/−0
• test/testdata/LiftToToplevel/WhereIn6.hs.expected +18/−0
• test/testdata/LiftToToplevel/WhereIn7.hs +12/−0
• test/testdata/LiftToToplevel/WhereIn7.hs.expected +13/−0
• test/testdata/LiftToToplevel/Zmapq.expected.hs +12/−0
• test/testdata/LiftToToplevel/Zmapq.hs +11/−0
• test/testdata/LocToName.hs +24/−0
• test/testdata/M.hs +9/−0
• test/testdata/M2.hs +7/−0
• test/testdata/M3.hs +8/−0
• test/testdata/MoveDef/Demote.hs +10/−0
• test/testdata/MoveDef/Demote.hs.expected +11/−0
• test/testdata/MoveDef/Md1.hs +43/−0
• test/testdata/MoveDef/Md1.hs.expected +43/−0
• test/testdata/MoveDef/Md1a.hs +9/−0
• test/testdata/MoveDef/Md1b.hs +14/−0
• test/testdata/MoveDef/Md2.hs +45/−0
• test/testdata/MoveDef/MultiFunBind1.hs +6/−0
• test/testdata/MoveDef/PatBind1.hs +6/−0
• test/testdata/NoMod.hs +18/−0
• test/testdata/Offset.hs +26/−0
• test/testdata/Renaming/A1.hs +10/−0
• test/testdata/Renaming/A1.hs.expected +10/−0
• test/testdata/Renaming/A2.hs +10/−0
• test/testdata/Renaming/A2_TokOut.hs +10/−0
• test/testdata/Renaming/A3.hs +10/−0
• test/testdata/Renaming/A3_TokOut.hs +10/−0
• test/testdata/Renaming/A4.hs +10/−0
• test/testdata/Renaming/A4.hs.expected +10/−0
• test/testdata/Renaming/A5.hs +10/−0
• test/testdata/Renaming/A5.hs.expected +10/−0
• test/testdata/Renaming/A6.hs +10/−0
• test/testdata/Renaming/B1.hs +20/−0
• test/testdata/Renaming/B1.hs.expected +20/−0
• test/testdata/Renaming/B2.hs +20/−0
• test/testdata/Renaming/B2.hs.expected +20/−0
• test/testdata/Renaming/B3.hs +20/−0
• test/testdata/Renaming/B3.hs.expected +20/−0
• test/testdata/Renaming/B4.hs +20/−0
• test/testdata/Renaming/B4.hs.expected +20/−0
• test/testdata/Renaming/B5.hs +20/−0
• test/testdata/Renaming/B5.hs.expected +20/−0
• test/testdata/Renaming/C1.hs +15/−0
• test/testdata/Renaming/C1.hs.expected +15/−0
• test/testdata/Renaming/C2.hs +15/−0
• test/testdata/Renaming/C2.hs.expected +15/−0
• test/testdata/Renaming/C3.hs +15/−0
• test/testdata/Renaming/C3.hs.expected +15/−0
• test/testdata/Renaming/C4.hs +15/−0
• test/testdata/Renaming/C4.hs.expected +15/−0
• test/testdata/Renaming/C5.hs +17/−0
• test/testdata/Renaming/C5.hs.expected +17/−0
• test/testdata/Renaming/C7.hs +11/−0
• test/testdata/Renaming/C7.hs.expected +11/−0
• test/testdata/Renaming/ClassIn1.hs +22/−0
• test/testdata/Renaming/ClassIn1.hs.expected +22/−0
• test/testdata/Renaming/ClassIn2.hs +22/−0
• test/testdata/Renaming/ClassIn2.hs.expected +22/−0
• test/testdata/Renaming/ClassIn3.hs +22/−0
• test/testdata/Renaming/ClassIn3_TokOut.hs +22/−0
• test/testdata/Renaming/ConflictExport.hs +15/−0
• test/testdata/Renaming/ConflictExport_TokOut.hs +15/−0
• test/testdata/Renaming/Constructor3.hs +23/−0
• test/testdata/Renaming/Constructor3_TokOut.hs +23/−0
• test/testdata/Renaming/ConstructorIn1.hs +22/−0
• test/testdata/Renaming/ConstructorIn1.hs.expected +22/−0
• test/testdata/Renaming/ConstructorIn2.hs +22/−0
• test/testdata/Renaming/ConstructorIn2.hs.expected +22/−0
• test/testdata/Renaming/ConstructorIn3.hs +23/−0
• test/testdata/Renaming/ConstructorIn3.hs.expected +23/−0
• test/testdata/Renaming/D1.hs +24/−0
• test/testdata/Renaming/D1.hs.expected +24/−0
• test/testdata/Renaming/D2.hs +24/−0
• test/testdata/Renaming/D2.hs.expected +24/−0
• test/testdata/Renaming/D3.hs +24/−0
• test/testdata/Renaming/D3.hs.expected +24/−0
• test/testdata/Renaming/D4.hs +24/−0
• test/testdata/Renaming/D4.hs.expected +24/−0
• test/testdata/Renaming/D5.hs +24/−0
• test/testdata/Renaming/D5.hs.expected +24/−0
• test/testdata/Renaming/D6.hs +16/−0
• test/testdata/Renaming/D6_TokOut.hs +16/−0
• test/testdata/Renaming/D7.hs +10/−0
• test/testdata/Renaming/D7.hs.expected +10/−0
• test/testdata/Renaming/Field1.hs +10/−0
• test/testdata/Renaming/Field1.hs.expected +10/−0
• test/testdata/Renaming/Field1_TokOut.hs +10/−0
• test/testdata/Renaming/Field2.hs +10/−0
• test/testdata/Renaming/Field2_TokOut.hs +10/−0
• test/testdata/Renaming/Field3.hs +13/−0
• test/testdata/Renaming/Field3.hs.expected +13/−0
• test/testdata/Renaming/Field4.hs +11/−0
• test/testdata/Renaming/Field4.hs.expected +11/−0
• test/testdata/Renaming/IdIn1.hs +19/−0
• test/testdata/Renaming/IdIn1.hs.expected +19/−0
• test/testdata/Renaming/IdIn2.hs +19/−0
• test/testdata/Renaming/IdIn2.hs.expected +19/−0
• test/testdata/Renaming/IdIn3.hs +18/−0
• test/testdata/Renaming/IdIn3_TokOut.hs +18/−0
• test/testdata/Renaming/IdIn4.hs +18/−0
• test/testdata/Renaming/IdIn4_TokOut.hs +18/−0
• test/testdata/Renaming/IdIn5.hs +17/−0
• test/testdata/Renaming/IdIn5_TokOut.hs +17/−0
• test/testdata/Renaming/LayoutIn1.hs +9/−0
• test/testdata/Renaming/LayoutIn1.hs.expected +9/−0
• test/testdata/Renaming/LayoutIn2.hs +13/−0
• test/testdata/Renaming/LayoutIn2.hs.expected +13/−0
• test/testdata/Renaming/LayoutIn3.hs +13/−0
• test/testdata/Renaming/LayoutIn3.hs.expected +13/−0
• test/testdata/Renaming/LayoutIn4.hs +13/−0
• test/testdata/Renaming/LayoutIn4.hs.expected +13/−0
• test/testdata/Renaming/Main.hs +11/−0
• test/testdata/Renaming/Main2.hs +7/−0
• test/testdata/Renaming/Main2.hs.expected +7/−0
• test/testdata/Renaming/Main_TokOut.hs +11/−0
• test/testdata/Renaming/QualClient.expected.hs +10/−0
• test/testdata/Renaming/QualClient.hs +10/−0
• test/testdata/Renaming/QualServer.expected.hs +12/−0
• test/testdata/Renaming/QualServer.hs +12/−0
• test/testdata/Renaming/Qualifier.hs +15/−0
• test/testdata/Renaming/Qualifier_TokOut.hs +15/−0
• test/testdata/Renaming/RenameInExportedType.expected.hs +8/−0
• test/testdata/Renaming/RenameInExportedType.hs +8/−0
• test/testdata/Renaming/RenameInExportedType2.expected.hs +8/−0
• test/testdata/Renaming/RenameInExportedType2.hs +8/−0
• test/testdata/Renaming/Utils.expected.hs +8/−0
• test/testdata/Renaming/Utils.hs +8/−0
• test/testdata/RmDecl3.hs +8/−0
• test/testdata/RmDecl4.hs +10/−0
• test/testdata/S1.hs +3/−0
• test/testdata/ScopeAndQual.hs +13/−0
• test/testdata/Simple/A.hs +4/−0
• test/testdata/Simple/A.hs.expected +4/−0
• test/testdata/SwapArgs/B.hs +36/−0
• test/testdata/TH/Main.hs +27/−0
• test/testdata/TH/Printf.hs +50/−0
• test/testdata/TokenTest.hs +25/−0
• test/testdata/TypeUtils/B.hs +32/−0
• test/testdata/TypeUtils/C.hs +5/−0
• test/testdata/TypeUtils/Empty.hs +2/−0
• test/testdata/TypeUtils/JustImports.hs +3/−0
• test/testdata/TypeUtils/LayoutLet1.hs +9/−0
• test/testdata/TypeUtils/LayoutLet2.hs +9/−0
• test/testdata/TypeUtils/Qualified.hs +5/−0
• test/testdata/TypeUtils/S.hs +11/−0
• test/testdata/TypeUtils/SelectivelyImports.hs +5/−0
• test/testdata/TypeUtils/Simplest.hs +4/−0
• test/testdata/TypeUtils/TyClDecls.hs +18/−0
• test/testdata/TypeUtils/TypeSigs.hs +14/−0
• test/testdata/TypeUtils/VisiblePNs.hs +106/−0
• test/testdata/Visible/Simple.hs +13/−0
• test/testdata/cabal/cabal1/Setup.hs +2/−0
• test/testdata/cabal/cabal1/cabal1.cabal +24/−0
• test/testdata/cabal/cabal1/src/Foo/Bar.hs +3/−0
• test/testdata/cabal/cabal1/src/main.hs +7/−0
• test/testdata/cabal/cabal2/Setup.hs +2/−0
• test/testdata/cabal/cabal2/cabal2.cabal +33/−0
• test/testdata/cabal/cabal2/src/Foo/Bar.hs +3/−0
• test/testdata/cabal/cabal2/src/main1.hs +7/−0
• test/testdata/cabal/cabal2/src/main2.hs +9/−0
• test/testdata/cabal/cabal3/Setup.hs +2/−0
• test/testdata/cabal/cabal3/cabal3.cabal +32/−0
• test/testdata/cabal/cabal3/src/Foo/Bar.hs +3/−0
• test/testdata/cabal/cabal3/src/main1.hs +7/−0
• test/testdata/cabal/cabal4/Setup.hs +2/−0
• test/testdata/cabal/cabal4/cabal4.cabal +29/−0
• test/testdata/cabal/cabal4/src/Foo/Bar.expected.hs +3/−0
• test/testdata/cabal/cabal4/src/Foo/Bar.hs +3/−0
• test/testdata/cabal/cabal4/src/main4.expected.hs +11/−0
• test/testdata/cabal/cabal4/src/main4.hs +11/−0
• test/testdata/cabal/foo/Setup.hs +2/−0
• test/testdata/cabal/foo/foo.cabal +32/−0
• test/testdata/cabal/foo/src/Foo/Bar.expected.hs +3/−0
• test/testdata/cabal/foo/src/Foo/Bar.hs +3/−0
• test/testdata/cabal/foo/src/Foo/Baz.hs +3/−0
• test/testdata/cabal/foo/src/Main.expected.hs +8/−0
• test/testdata/cabal/foo/src/Main.hs +8/−0
• test/testdata/testdata.cabal +155/−0

@@ -1,3 +1,7 @@+2015-10-04 v0.8.0.0+	* Major rework, replacing haskell-token-utils with ghc-exactprint+	* Now supports GHC 7.10.2 and up. ONLY.+	* Functionally equivalent to v0.7.2.8 2014-10-13 v0.7.2.8 	lower bounds on parsec and haskell-token-utils 2014-08-20 v0.7.2.7@@ -87,18 +91,18 @@ 	* Now able to get tokens for a file pre-processed with CPP. But it 	is the pre-processed output, so the CPP directives are stripped 	out when writing out the refactored source.-	+ 2013-09-11  v0.7.0.4 	* Correct Haddock compile error. Close #4 	* hsWithBndrs only exists for GHC > 7.4.x 2013-09-10  v0.7.0.3-	+ 	* Fix elisp, would not commit refactoring due to missing methods-	+ 2013-09-08  v0.7.0.2  	* Fix issue #3: ifToCase formatting-	+ 2013-09-05  v0.7.0.1  	* Fix issue #2: elisp

@@ -1,5 +1,5 @@ Name:                           HaRe-Version:                        0.7.2.8+Version:                        0.8.0.0 Author:                         Chris Brown, Huiqing Li, Simon Thompson, Alan Zimmerman Maintainer:                     Alan Zimmerman Stability:                      Alpha@@ -11,50 +11,118 @@    A Haskell 2010 refactoring tool. HaRe supports the full    Haskell 2010 standard, through making use of the GHC API.    .-   It is tested against GHC 7.4.x and 7.6.x (via travis-ci.org)+   Version 0.7.2.8 supports up to GHC 7.6.3.    .+   There is no support for GHC 7.8.x. There will never be support for GHC 7.8.x+   .+   From version 0.8.0.0, GHC 7.10.2 is supported.+   .+   It is tested against GHC 7.10.2 (via travis-ci.org)+   .    It currently only has emacs integration built in, community input    welcome for others.    .-   Warning: This is alpha code. Always commit code to your version-   control system before refactoring. The developers make no-   warranties, use at your own risk.-   .-   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.+   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-   and demoting+   Even so, it is strongly advised to back up any source files before+   refactoring, as we can make no promises as to the reliability of this tool.+   Use at your own risk.    .    At the moment parsing of any file with FFI exports will fail.    .-+   See Language.Haskell.Refact.HaRe for the current list of refactorings supported+   . Synopsis:                       the Haskell Refactorer. Category:                       Development, Refactoring Cabal-Version:                  >= 1.8 Build-Type:                     Simple++tested-with:                    GHC == 7.10.2+ data-files:                     elisp/*.el+                                configure.sh+                                test/testdata/*.cabal+                                test/testdata/*.hs+                                test/testdata/Case/*.hs+                                test/testdata/Case/*.hs.expected+                                test/testdata/Case/*.hs.expected.dd+                                test/testdata/Demote/*.expected.hs+                                test/testdata/Demote/*.hs+                                test/testdata/Demote/*.hs.expected+                                test/testdata/DupDef/*.hs+                                test/testdata/DupDef/*.hs.expected+                                test/testdata/DupDef/*.hs.expected.dd+                                test/testdata/DupDef/*.hs.expected.gg+                                test/testdata/DupDef/*.hs.expected.ll+                                test/testdata/DupDef/*.hs.expected.mm+                                test/testdata/DupDef/*.hs.expected.nn+                                test/testdata/FreeAndDeclared/*.hs+                                test/testdata/Layout/*.hs+                                test/testdata/Layout/*.hs.expected+                                test/testdata/LiftOneLevel/*.hs+                                test/testdata/LiftOneLevel/*.hs.expected+                                test/testdata/LiftToToplevel/*.expected.hs+                                test/testdata/LiftToToplevel/*.hs+                                test/testdata/LiftToToplevel/*.hs.expected+                                test/testdata/MoveDef/*.hs+                                test/testdata/MoveDef/*.hs.expected+                                test/testdata/Renaming/*.expected.hs+                                test/testdata/Renaming/*.hs+                                test/testdata/Renaming/*.hs.expected+                                test/testdata/Simple/*.hs+                                test/testdata/Simple/*.hs.expected+                                test/testdata/SwapArgs/*.hs+                                test/testdata/TH/*.hs+                                test/testdata/TypeUtils/*.hs+                                test/testdata/Visible/*.hs+                                test/testdata/cabal/cabal1/*.cabal+                                test/testdata/cabal/cabal1/*.hs+                                test/testdata/cabal/cabal1/src/*.hs+                                test/testdata/cabal/cabal1/src/Foo/*.hs+                                test/testdata/cabal/cabal2/*.cabal+                                test/testdata/cabal/cabal2/*.hs+                                test/testdata/cabal/cabal2/src/*.hs+                                test/testdata/cabal/cabal2/src/Foo/*.hs+                                test/testdata/cabal/cabal3/*.cabal+                                test/testdata/cabal/cabal3/*.hs+                                test/testdata/cabal/cabal3/src/*.hs+                                test/testdata/cabal/cabal3/src/Foo/*.hs+                                test/testdata/cabal/cabal4/*.cabal+                                test/testdata/cabal/cabal4/*.hs+                                test/testdata/cabal/cabal4/src/*.expected.hs+                                test/testdata/cabal/cabal4/src/*.hs+                                test/testdata/cabal/cabal4/src/Foo/*.expected.hs+                                test/testdata/cabal/cabal4/src/Foo/*.hs+                                test/testdata/cabal/foo/*.cabal+                                test/testdata/cabal/foo/*.hs+                                test/testdata/cabal/foo/src/*.expected.hs+                                test/testdata/cabal/foo/src/*.hs+                                test/testdata/cabal/foo/src/Foo/*.expected.hs+                                test/testdata/cabal/foo/src/Foo/*.hs+ data-Dir:                       . extra-source-files:             ChangeLog  Library-        Build-Depends:          base >= 4.0  && < 4.8+        -- GHC 7.10.2 ships with base 4.8.1.0+        Build-Depends:          base >= 4.8.1.0  && < 4.9                                 , containers                                 , directory -                                , dual-tree+                                -- , dual-tree                                 , semigroups                                 , monoid-extras +                                , cabal-helper                                 , filepath                                 , ghc                                 , ghc-paths                                 , ghc-prim                                 , ghc-syb-utils-                                , ghc-mod >= 4.1.0 && < 5+                                , ghc-mod >= 5.4                                 , mtl                                 , old-time                                 , pretty@@ -62,13 +130,16 @@                                 , syb                                 , hslogger                                 , transformers+                                , transformers-base                                 , time                                 , Strafunski-StrategyLib                                 , syz--                                , haskell-token-utils >= 0.0.0.6+                                , ghc-exactprint >= 0.4.1+                                , monad-control+                                , Cabal >= 1.22+                                -- , uniplate -        GHC-Options:             -Wall+        -- GHC-Options:             -Wall -O0          Hs-Source-Dirs:         src         -- Other-Modules:          Paths_HaRe@@ -79,8 +150,11 @@            , Language.Haskell.Refact.Refactoring.DupDef            , Language.Haskell.Refact.Refactoring.MoveDef            , Language.Haskell.Refact.Refactoring.Renaming+           , Language.Haskell.Refact.Refactoring.RoundTrip            , Language.Haskell.Refact.Refactoring.SwapArgs+           , Language.Haskell.Refact.Refactoring.Simple            , Language.Haskell.Refact.Utils.Binds+           , Language.Haskell.Refact.Utils.ExactPrint            , Language.Haskell.Refact.Utils.GhcBugWorkArounds            , Language.Haskell.Refact.Utils.GhcModuleGraph            , Language.Haskell.Refact.Utils.GhcUtils@@ -88,37 +162,60 @@            , Language.Haskell.Refact.Utils.LocUtils            , Language.Haskell.Refact.Utils.Monad            , Language.Haskell.Refact.Utils.MonadFunctions-           , Language.Haskell.Refact.Utils.TokenUtils            , Language.Haskell.Refact.Utils.TypeSyn            , Language.Haskell.Refact.Utils.TypeUtils+           , Language.Haskell.Refact.Utils.Types            , Language.Haskell.Refact.Utils.Utils+           , Language.Haskell.Refact.Utils.Variables            , Paths_HaRe-        Extensions:      CPP-+        if impl (ghc < 7.10.2)+            buildable: False   Executable ghc-hare         Main-Is:                MainHaRe.hs         -- Other-Modules:          Paths_HaRe-        GHC-Options:            -Wall+        -- GHC-Options:            -Wall -O0         -- GHC-Options:            -prof -fprof-auto -rtsopts -caf-all         Hs-Source-Dirs:           ./src-        Build-Depends:          base >= 4.0  && < 4.8+        other-modules:+             Language.Haskell.Refact.API+           , Language.Haskell.Refact.HaRe+           , Language.Haskell.Refact.Refactoring.Case+           , Language.Haskell.Refact.Refactoring.RoundTrip+           , Language.Haskell.Refact.Utils.Binds+           , Language.Haskell.Refact.Utils.ExactPrint+           , Language.Haskell.Refact.Utils.GhcModuleGraph+           , Language.Haskell.Refact.Utils.GhcUtils+           , Language.Haskell.Refact.Utils.GhcVersionSpecific+           , Language.Haskell.Refact.Utils.LocUtils+           , Language.Haskell.Refact.Utils.Monad+           , Language.Haskell.Refact.Utils.MonadFunctions+           , Language.Haskell.Refact.Utils.TypeSyn+           , Language.Haskell.Refact.Utils.TypeUtils+           , Language.Haskell.Refact.Utils.Types+           , Language.Haskell.Refact.Utils.Utils+           , Language.Haskell.Refact.Utils.Variables+           , Paths_HaRe++        -- GHC 7.10.2 ships with base 4.8.1.0+        Build-Depends:          base >= 4.8.1.0  && < 4.9                                 , array                                 , containers                                 , directory -                                , dual-tree+                                -- , dual-tree                                 , semigroups                                 , monoid-extras +                                , cabal-helper                                 , filepath                                 , ghc                                 , ghc-paths                                 , ghc-prim                                 , ghc-syb-utils-                                , ghc-mod >= 4.1.0 && < 5+                                , ghc-mod >= 5.4                                 , mtl                                 , old-time                                 , parsec >= 3.1.6@@ -127,18 +224,24 @@                                 , syb                                 , time                                 , transformers+                                , transformers-base                                 , hslogger                                 , Strafunski-StrategyLib                                 , syz-                                , haskell-token-utils >= 0.0.0.6-                                , HaRe >= 0.7.2.3+                                , ghc-exactprint >= 0.4.1+                                , monad-control+                                , Cabal >= 1.22+                                -- , Paths_HaRe+                                , HaRe >= 0.8         Extensions:      CPP-+        if impl (ghc < 7.10.2)+            buildable: False  test-suite spec   type:       exitcode-stdio-1.0   ghc-options:+      -- -O0       -- reinstate these later  -Wall       -- -Wall       -- reinstate these later  -Werror@@ -151,27 +254,41 @@   Hs-Source-Dirs:     -- src     test+  other-modules:+      CaseSpec+    , DupDefSpec+    , GhcUtilsSpec+    , LocUtilsSpec+    , MonadFunctionsSpec+    , MoveDefSpec+    , RenamingSpec+    , RoundTripSpec+    , SimpleSpec+    , SwapArgsSpec+    , TestUtils+    , TypeUtilsSpec+    , UtilsSpec   build-depends:-      base        >= 4.0  && < 4.8+      -- GHC 7.10.2 ships with base 4.8.1.0+      base        >= 4.8.1.0  && < 4.9     , Diff >= 0.3.0-    -- , HUnit       == 1.2.*     , HUnit     , QuickCheck  >= 2.5     , containers -    , dual-tree+    -- , dual-tree     , semigroups     , monoid-extras      , deepseq     , directory     , filepath-    , ghc         >= 7.0.1 && < 7.8+    , ghc     -- , ghc-paths   == 0.1.*     , ghc-paths     , ghc-prim     , ghc-syb-utils-    , ghc-mod >= 4.1.0 && < 5+    , ghc-mod >= 5.4     , hspec     , mtl     , old-time@@ -181,20 +298,27 @@     , rosezipper     , syb     , transformers+    , transformers-base     , time     , hslogger     , Strafunski-StrategyLib     , syz-    , haskell-token-utils >= 0.0.0.6-    , HaRe >= 0.7.2.3+    , ghc-exactprint >= 0.4.1+    , monad-control+    , Cabal >= 1.22+    -- , uniplate+    -- , Paths_HaRe+    -- , haskell-token-utils >= 0.0.0.6+    , HaRe >= 0.8   Extensions:      CPP-+  if impl (ghc < 7.10.2)+    buildable: False  -- test-suite doctests --   type:          exitcode-stdio-1.0 --   ghc-options:   -threaded --   main-is:       doctests.hs---   build-depends: base        >= 4.0  && < 4.8+--   build-depends: base        >= 4.0  && < 4.9 --                , doctest >= 0.8 --                , ghc-mod --   Hs-Source-Dirs:

@@ -0,0 +1,14 @@+#!/bin/sh++# This script is temporary until ghc-mod is fixed to reconfigure on change++cabal clean && cabal configure  --enable-tests --disable-optimization++# Make sure the tests run against the newly installed environment+(cd test/testdata && cabal clean && cabal configure)++(cd test/testdata/cabal/cabal1 && cabal clean && cabal configure)+(cd test/testdata/cabal/cabal2 && cabal clean && cabal configure)+(cd test/testdata/cabal/cabal3 && cabal clean && cabal configure)+(cd test/testdata/cabal/cabal4 && cabal clean && cabal configure)+(cd test/testdata/cabal/foo    && cabal clean && cabal configure)

@@ -91,6 +91,7 @@     (define-key haskell-mode-map "\C-c\C-rlo"  'hare-refactor-lift-one)     (define-key haskell-mode-map "\C-c\C-rlt"  'hare-refactor-lifttotop)     (define-key haskell-mode-map "\C-c\C-rr"   'hare-refactor-rename)+    (define-key haskell-mode-map "\C-c\C-rt"   'hare-refactor-roundtrip)     (define-key haskell-mode-map "\C-c\C-rsh"  'hare-refactor-show)     (hare-init-menu)     (setq hare-initialized t)))@@ -112,7 +113,8 @@   (define-key haskell-mode-map [menu-bar mymenu lo] '("Lift one level"       . hare-refactor-lift-one))   (define-key haskell-mode-map [menu-bar mymenu lt] '("Lift to top level"    . hare-refactor-lifttotop))   (define-key haskell-mode-map [menu-bar mymenu r ] '("Rename"               . hare-refactor-rename))-  (define-key haskell-mode-map [menu-bar mymenu sh ] '("Show"                 . hare-refactor-show))+  (define-key haskell-mode-map [menu-bar mymenu r ] '("Round trip"           . hare-refactor-roundtrip))+  (define-key haskell-mode-map [menu-bar mymenu sh ] '("Show"                . hare-refactor-show)) )  (defun hare-init-interactive ()@@ -1048,6 +1050,23 @@     (if (buffers-saved)         (hare-refactor-command current-file-name line-no column-no                          `("rename" ,current-file-name ,name+                         ,(number-to-string line-no) ,(number-to-string column-no)+                         )+                         hare-search-paths 'emacs tab-width)+      (message "Refactoring aborted."))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++(defun hare-refactor-roundtrip ()+  "Round trip a source file, to check HaRe plumbing."+  (interactive)+  (let ((current-file-name (buffer-file-name))+        (line-no           (current-line-no))+        (column-no         (current-column-no))+        (buffer (current-buffer)))+    (if (buffers-saved)+        (hare-refactor-command current-file-name line-no column-no+                         `("roundtrip" ,current-file-name                          ,(number-to-string line-no) ,(number-to-string column-no)                          )                          hare-search-paths 'emacs tab-width)

@@ -17,22 +17,15 @@        , getRefacSettings        , defaultSettings        , logSettings-       , initGhcSession -       , loadModuleGraphGhc-       , ensureTargetLoaded-       , canonicalizeGraph-        , logm+       , logDataWithAnns   -- * from `Language.Haskell.Refact.Utils.Utils`         -- ** Managing the GHC / project environment-       -- , loadModuleGraphGhc-       , getModuleGhc        , parseSourceFileGhc-       , activateModule-       , getModuleDetails+       , getTargetGhc         -- ** The bits that do the work        , runRefacSession@@ -41,8 +34,7 @@        , ApplyRefacResult        , RefacSource(..) -       , update-       , fileNameToModName+       , nameSybQuery        , fileNameFromModSummary        , getModuleName        , clientModsAndFiles@@ -53,44 +45,27 @@         -- ** Conveniences for state access -       -- , fetchToksFinal-       , fetchLinesFinal-       , fetchOrigToks-       , fetchToks -- Deprecated        , getTypecheckedModule+       , RefacResult(..)        , getRefactStreamModified+       , setRefactStreamModified        , getRefactInscopes        , getRefactRenamed        , putRefactRenamed        , getRefactParsed+       , putRefactParsed        , putParsedModule        , clearParsedModule        , getRefactFileName--       -- ** TokenUtils API-       , replaceToken-       , putToksForSpan-       , putDeclToksForSpan-       , getToksForSpan-       -- , getToksForSpanNoInv-       -- , getToksForSpanWithIntros-       , getToksBeforeSpan-       , putToksForPos-       , addToksAfterSpan-       , addToksAfterPos-       , putDeclToksAfterSpan-       , removeToksForSpan-       , removeToksForPos-       , syncDeclToLatestStash-       , indentDeclAndToks+       , getRefactTargetModule+       , getRefactNameMap -       -- ** LayoutUtils API+       , getRefactModule+       , getRefactModuleName -       -- ** For debugging-       , drawTokenTree-       , drawTokenTreeDetailed-       , getTokenTree-       , showLinesDebug+       -- * New ghc-exactprint interfacing+       -- , refactRunTransform+       , liftT         -- ** State flags for managing generic traversals        , getRefactDone@@ -102,108 +77,21 @@         -- , logm -       , updateToks-       , updateToksWithPos   -- * from `Language.Haskell.Refact.Utils.LocUtils` -                     , SimpPos,unmodified,modified-                     , simpPos0-                     , nullSrcSpan-                     -- , showToks-                     , whiteSpaceTokens-                     , realSrcLocFromTok-                     , isWhite-                     , notWhite-                     , isWhiteSpace-                     , isWhiteSpaceOrIgnored-                     , isIgnored-                     , isIgnoredNonComment-                     {--                     ,isNewLn,isCommentStart -},isComment {-,-                     isNestedComment-},isMultiLineComment {-,isOpenBracket,isCloseBracket, -}-                     ,isOpenSquareBracket,isCloseSquareBracket {- ,isOpenBrace,isConid,-                     isLit,isWhereOrLet,isWhere,isLet-},isIn {- ,isCase,isDo,isIf,isForall,-                     isHiding,isModule-} ,isComma {-,isEqual,isLambda,isIrrefute -},isBar --,isMinus,-                     ,endsWithNewLn,startsWithNewLn,hasNewLn {- ,startsWithEmptyLn,-                     lastNonSpaceToken,firstNonSpaceToken -} ,compressPreNewLns,compressEndNewLns+                     , SimpPos -                     , lengthOfLastLine-                     , getToks-                     -- , replaceToks,replaceTok-                     ,replaceTokNoReAlign,deleteToks,doRmWhites -- ,doAddWhites-                     , srcLocs-                     , getSrcSpan, getAllSrcLocs-                     -- , ghcSrcLocs -- Test version-                     -- , getLocatedStart-                     -- , getLocatedEnd-                     , getBiggestStartEndLoc-                     {--                     , getStartEndLoc2,-                     startEndLoc,extendBothSides -},extendForwards,extendBackwards-                     , startEndLocIncFowComment{- ,startEndLocIncFowNewLn -}-                     , startEndLocIncComments, startEndLocIncComments'-                     , tokenise-                     , basicTokenise-                     , prettyprintPatList-                     , groupTokensByLine-                     , toksOnSameLine-                     , addLocInfo-                     -- , getIndentOffset-                     , getLineOffset-                     -- , splitToks-                     -- , splitOnNewLn-                     {--                     , insertComments,-                     extractComments, insertTerms-                     -}-                     , tokenCol-                     , tokenColEnd-                     , tokenRow-                     , tokenPos-                     , tokenPosEnd-                     , tokenSrcSpan-                     , tokenCon-                     , increaseSrcSpan                      , getGhcLoc                      , getGhcLocEnd                      , getLocatedStart                      , getLocatedEnd                      , getStartEndLoc                      , startEndLocGhc-                     , realSrcLocEndTok-                     , fileNameFromTok-                     , splitToks                      , emptyList, nonEmptyList-                     -- , divideComments-                     , notWhiteSpace-                     , isDoubleColon-                     , isEmpty-                     , isWhereOrLet-                     , isWhere-                     , isLet-                     , isElse-                     , isThen-                     , isOf-                     , isDo-                     , getIndentOffset-                     , splitOnNewLn-                     , tokenLen-                     , newLnToken-                     -- , newLinesToken-                     -- , monotonicLineToks-                     , reSequenceToks-                     , mkToken-                     , mkZeroToken-                     , markToken-                     , isMarked-                     , addOffsetToToks-                     , matchTokenPos-                     , rmOffsetFromToks   -- * from `Language.Haskell.Refact.Utils.TypeSyn`     , InScopes-    , PosToken     , ghead     , glast     , gtail@@ -214,139 +102,116 @@  -- ** Program Analysis     -- ** Imports and exports    , inScopeInfo, isInScopeAndUnqualified, isInScopeAndUnqualifiedGhc, inScopeNames-   -- , hsQualifier, {-This function should be removed-} rmPrelude-   {-,exportInfo -}, isExported, isExplicitlyExported, modIsExported+   , isExported, isExplicitlyExported, modIsExported+   , equivalentNameInNewMod      -- *** Variable analysis     , isFieldName     , isClassName     , isInstanceName-    ,hsPNs -- ,hsDataConstrs,hsTypeConstrsAndClasses, hsTypeVbls-    {- ,hsClassMembers -} , hsBinds, replaceBinds, HsValBinds(..)-    ,isDeclaredIn+    , hsPNs+    , hsBinds+    , HsValBinds(..)+    ,isDeclaredIn,isDeclaredInRdr+    ,FreeNames(..),DeclaredNames(..)     ,hsFreeAndDeclaredPNsOld, hsFreeAndDeclaredNameStrings+    ,hsFreeAndDeclaredRdr     ,hsFreeAndDeclaredPNs     ,hsFreeAndDeclaredGhc     ,getDeclaredTypes     ,getFvs, getFreeVars, getDeclaredVars -- These two should replace hsFreeAndDeclaredPNs -    ,hsVisiblePNs {- , hsVisiblePNsOld -}, hsVisibleNames+    ,hsVisiblePNs, hsVisiblePNsRdr, hsVisibleNames+    ,hsVisibleNamesRdr+    ,hsFDsFromInsideRdr, hsFDNamesFromInsideRdr     ,hsFDsFromInside, hsFDNamesFromInside     ,hsVisibleDs+    ,rdrName2Name, rdrName2NamePure      -- *** Property checking     ,isVarId,isConId,isOperator,isTopLevelPN,isLocalPN,isNonLibraryName -- ,isTopLevelPNT-    ,isQualifiedPN {- , isFunName, isPatName-}, isFunOrPatName {-,isTypeCon-} ,isTypeSig-    ,isFunBindP,isFunBindR,isPatBindP,isPatBindR,isSimplePatBind-    ,isComplexPatBind,isFunOrPatBindP,isFunOrPatBindR -- ,isClassDecl,isInstDecl -- ,isDirectRecursiveDef-    ,usedWithoutQualR {- ,canBeQualified, hasFreeVars -},isUsedInRhs+    ,isQualifiedPN, isFunOrPatName,isTypeSig+    ,isFunBindP,isFunBindR,isPatBindP,isPatBindR,isSimplePatBind,isSimplePatDecl+    ,isComplexPatBind,isComplexPatDecl,isFunOrPatBindP,isFunOrPatBindR+    ,usedWithoutQualR,isUsedInRhs+    ,findNameInRdr     ,findPNT,findPN,findAllNameOccurences-    ,findPNs, findEntity, findEntity'+    ,findPNs, findNamesRdr, findEntity, findEntity'     ,sameOccurrence     , findIdForName     , getTypeForName-    ,defines, definesP,definesTypeSig -- , isTypeSigOf-    -- ,HasModName(hasModName), HasNameSpace(hasNameSpace)-    ,sameBind-    {- ,usedByRhs -},UsedByRhs(..)+    ,defines, definesP,definesTypeSig+    ,sameBind,sameBindRdr+    ,UsedByRhs(..)      -- *** Modules and files-    -- ,clientModsAndFiles,serverModsAndFiles,isAnExistingMod-    -- ,fileNameToModName, strToModName, modNameToStr     , isMainModule     , getModule      -- *** Locations-    ,defineLoc, useLoc, locToExp  -- , getStartEndLoc+    ,defineLoc, useLoc, locToExp      ,locToName, locToRdrName     ,getName   -- * Program transformation     -- *** Adding-    ,addDecl, addItemsToImport, addHiding --, rmItemsFromImport, addItemsToExport-    ,addParamsToDecls, addActualParamsToRhs {- , addGuardsToRhs-}, addImportDecl, duplicateDecl -- , moveDecl+    ,addDecl, addItemsToImport, addHiding+    ,addParamsToDecls, addActualParamsToRhs, addImportDecl, duplicateDecl -- , moveDecl     -- *** Removing-    ,rmDecl, rmTypeSig, rmTypeSigs -- , commentOutTypeSig, rmParams-    -- ,rmItemsFromExport, rmSubEntsFromExport, Delete(delete)+    ,rmDecl, rmTypeSig, rmTypeSigs      -- *** Updating-    -- ,Update(update)-    {- ,qualifyPName-},rmQualifier,qualifyToplevelName,renamePN {- ,replaceNameInPN -},autoRenameLocalVar+    ,Update(update)+    ,rmQualifier,qualifyToplevelName,renamePN',autoRenameLocalVar      -- ** Miscellous     -- *** Parsing, writing and showing-    {- ,parseSourceFile,writeRefactoredFiles-}, showEntities,showPNwithLoc -- , newProj, addFile, chase+    , showEntities,showPNwithLoc     -- *** Locations     -- ,toRelativeLocs, rmLocs     -- *** Default values-   ,defaultPN {- ,defaultPNT -},defaultName {-,defaultModName-},defaultExp -- ,defaultPat, defaultExpUnTyped+   ,defaultPN,defaultName,defaultExp       -- *** Identifiers, expressions, patterns and declarations-    ,ghcToPN,lghcToPN, expToName+    ,ghcToPN,lghcToPN, expToName, expToNameRdr+    ,patToNameRdr     ,nameToString-    {- ,expToPNT, expToPN, nameToExp,pNtoExp -},patToPNT {- , patToPN --, nameToPat -},pNtoPat-    {- ,definingDecls -}, definedPNs+    ,patToPNT ,pNtoPat+    , definedPNs, definedPNsRdr,definedNamesRdr+    , definingDeclsRdrNames, definingDeclsRdrNames', definingSigsRdrNames     , definingDeclsNames, definingDeclsNames', definingSigsNames     , definingTyClDeclsNames     , allNames-    -- ,simplifyDecl      -- *** Others+    , divideDecls     , mkRdrName,mkNewGhcName,mkNewName,mkNewToplevelName      -- The following functions are not in the the API yet.-    , causeNameClashInExports {- , inRegion , unmodified -}+    , causeNameClashInExports -    , removeOffset+    -- , removeOffset +    , declsSybTransform+     -- ** Typed AST traversals (added by CMB)     -- ** Miscellous-    -- ,removeFromInts, getDataName, checkTypes, getPNs, getPN, getPNPats, mapASTOverTAST      -- ** Debug stuff-    , getDeclAndToks, getSigAndToks-    , getToksForDecl, removeToksOffset -- ++AZ++ remove this after debuggging     , getParsedForRenamedLPat     , getParsedForRenamedName     , getParsedForRenamedLocated-    -- , allPNT-    --  , allPNTLens-    -- , newNameTok     , stripLeadingSpaces-    -- , lookupNameGhc   -- ** from `Language.Haskell.Refact.Utils.GhcUtils`     -- ** SYB versions-    , everythingButStaged-    , somethingStaged-    , everythingStaged-    , somewhereMStaged-    , somewhereMStagedBu-    , everywhereMStaged     , everywhereMStaged'     , everywhereStaged     , everywhereStaged'     , onelayerStaged     , listifyStaged -    -- *** SYB Utility-    , checkItemRenamer--    -- ** Strafunski StrategyLib versions-    , full_tdTUGhc-    , stop_tdTUGhc-    , stop_tdTPGhc-    , allTUGhc'-    , once_tdTPGhc-    , once_buTPGhc-    , oneTPGhc-    , allTUGhc--    -- *** Strafunski utility-    , checkItemStage'-    , checkItemRenamer'-     -- ** Scrap Your Zipper versions     , zeverywhereStaged     , zopenStaged@@ -356,41 +221,38 @@     , zopenStaged'     , ztransformStagedM     -- *** SYZ utilities-    , checkZipperStaged     , upUntil     , findAbove   -- * from `Language.Haskell.Refact.Utils.GhcVersionSpecific`   , showGhc+  , showGhcQual   , prettyprint   , prettyprint2   , ppType-  , lexStringToTokens-  , getDataConstructors   , setGhcContext   -- * from `Language.Haskell.Refact.Utils.TokenUtils`- , Positioning(..)- , reIndentToks- , ghcSrcSpanToForestSpan+  , NameMap - -- * Span conversion functions- , gs2f,f2gs- , gs2ss,ss2gs+ -- * from `Language.Haskell.Refact.Utils.ExactPrint'`+ , replace+ , setRefactAnns+  ) where  import Language.Haskell.Refact.Utils.Binds+import Language.Haskell.Refact.Utils.ExactPrint import Language.Haskell.Refact.Utils.GhcUtils import Language.Haskell.Refact.Utils.GhcVersionSpecific import Language.Haskell.Refact.Utils.LocUtils import Language.Haskell.Refact.Utils.Monad import Language.Haskell.Refact.Utils.MonadFunctions-import Language.Haskell.Refact.Utils.TokenUtils import Language.Haskell.Refact.Utils.TypeSyn import Language.Haskell.Refact.Utils.TypeUtils+import Language.Haskell.Refact.Utils.Types import Language.Haskell.Refact.Utils.Utils+import Language.Haskell.Refact.Utils.Variables -import Language.Haskell.TokenUtils.Types-import Language.Haskell.TokenUtils.TokenUtils-import Language.Haskell.TokenUtils.Utils-import Language.Haskell.TokenUtils.GHC.Layout+import Language.Haskell.GHC.ExactPrint.Utils+

@@ -8,14 +8,14 @@  , SimpPos   -- * Refactorings- -- |Note: the 'Cradle' in the type signatures is the one from ghc-mod  , ifToCase  , duplicateDef  , liftToTopLevel  , liftOneLevel  , demote  , rename- , swapArgs+ -- , swapArgs+ , roundTrip  ) where @@ -23,7 +23,9 @@ import Language.Haskell.Refact.Refactoring.DupDef import Language.Haskell.Refact.Refactoring.MoveDef import Language.Haskell.Refact.Refactoring.Renaming-import Language.Haskell.Refact.Refactoring.SwapArgs+-- import Language.Haskell.Refact.Refactoring.SwapArgs+import Language.Haskell.Refact.Refactoring.RoundTrip import Language.Haskell.Refact.Utils.Monad-import Language.Haskell.TokenUtils.Types+import Language.Haskell.Refact.Utils.Types+ 

@@ -1,231 +1,147 @@+{-# LANGUAGE StandaloneDeriving #-} module Language.Haskell.Refact.Refactoring.Case(ifToCase) where  import qualified Data.Generics         as SYB import qualified GHC.SYB.Utils         as SYB +import qualified BasicTypes    as GHC import qualified GHC           as GHC -import Control.Monad-import Control.Monad.IO.Class-import Language.Haskell.GhcMod+import qualified Language.Haskell.GhcMod as GM (Options(..)) import Language.Haskell.Refact.API +-- To be moved into HaRe API+import Language.Haskell.GHC.ExactPrint+import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Utils++import System.Directory+import qualified Data.Map as Map+-- import Debug.Trace+ -- ---------------------------------------------------------------------  -- | Convert an if expression to a case expression-ifToCase :: RefactSettings -> Cradle -> FilePath -> SimpPos -> SimpPos -> IO [FilePath]-ifToCase settings cradle fileName beginPos endPos =-  runRefacSession settings cradle (comp fileName beginPos endPos)+ifToCase :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> SimpPos -> IO [FilePath]+ifToCase settings opts fileName beginPos endPos = do+  absFileName <- canonicalizePath fileName+  runRefacSession settings opts (comp absFileName beginPos endPos)  comp :: FilePath -> SimpPos -> SimpPos -> RefactGhc [ApplyRefacResult] comp fileName beginPos endPos = do-       getModuleGhc fileName-       renamed <- getRefactRenamed-       logm $ "Case.comp:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++-       let expr = locToExp beginPos endPos renamed-       -- logm $ "Case.comp:expr=" ++ (SYB.showData SYB.Renamer 0 expr) -- ++AZ+++       parseSourceFileGhc fileName+       parsed <- getRefactParsed+       oldAnns <- liftT getAnnsT+       logm $ "Case.comp:parsed=" ++ (showAnnData oldAnns 0 parsed) -- ++AZ+++       let expr = locToExp beginPos endPos parsed        case expr of          Just exp1@(GHC.L _ (GHC.HsIf _ _ _ _))                 -> do (refactoredMod,_) <- applyRefac (doIfToCaseInternal exp1) RSAlreadyLoaded                       return [refactoredMod]-         _      -> error $ "You haven't selected an if-then-else  expression!" --  ++ (show (beginPos,endPos,fileName)) ++ "]:" ++ (SYB.showData SYB.Parser 0 $ ast)+         _      -> error $ "You haven't selected an if-then-else  expression!" -- (show (beginPos,endPos,fileName)) ++ "]:" ++ (SYB.showData SYB.Parser 0 $ ast)  doIfToCaseInternal ::-  GHC.Located (GHC.HsExpr GHC.Name)+  GHC.Located (GHC.HsExpr GHC.RdrName)   -> RefactGhc () doIfToCaseInternal expr = do-  rs <- getRefactRenamed+  rs <- getRefactParsed   reallyDoIfToCase expr rs  reallyDoIfToCase ::-  GHC.Located (GHC.HsExpr GHC.Name)-  -> GHC.RenamedSource+  GHC.Located (GHC.HsExpr GHC.RdrName)+  -> GHC.ParsedSource   -> RefactGhc ()-reallyDoIfToCase expr rs = do+reallyDoIfToCase expr p = do -   void $ everywhereMStaged SYB.Renamer (SYB.mkM inExp) rs-   showLinesDebug "after refactoring"+   p2 <- SYB.everywhereMStaged SYB.Parser (SYB.mkM inExp) p+   putRefactParsed p2 mempty    return ()        where-         inExp :: (GHC.Located (GHC.HsExpr GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name))-         inExp exp1@(GHC.L l (GHC.HsIf _se (GHC.L l1 _) (GHC.L l2 _) (GHC.L l3 _)))+         inExp :: (GHC.Located (GHC.HsExpr GHC.RdrName)) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.RdrName))+         inExp exp1@(GHC.L _ (GHC.HsIf _se (GHC.L _ _) (GHC.L _ _) (GHC.L _ _)))            | sameOccurrence expr exp1            = do-               -- drawTokenTreeDetailed "reallyDoIfToCase" -- ++AZ++ debug                newExp <- ifToCaseTransform exp1--               -- let (GHC.RealSrcLoc rl) = GHC.srcSpanStart l-               let caseTok = tokenise (gs2ss l) 0 False "case"-               condToks <- getToksForSpan l1-               let ofTok = tokenise-                     (gs2ss $ tokenSrcSpan (glast "reallyDoIfToCase" condToks))-                     -- (realSrcLocFromTok (glast "reallyDoIfToCase" condToks))-                           1 True "of"-               let trueToks = basicTokenise "True  ->"-               let falseToks = basicTokenise "False ->"-               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'--               let t2 = reIndentToks (PlaceIndent 1 4 0) t1 trueToks-               let t3 = reIndentToks PlaceAdjacent (t1++t2) thenToks--               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)]--               logm $ "reallyDoIfToCase:t1=[" ++ (GHC.showRichTokenStream t1) ++ "]"-               logm $ "reallyDoIfToCase:t2=[" ++ (GHC.showRichTokenStream t2) ++ "]"-               logm $ "reallyDoIfToCase:t3=[" ++ (GHC.showRichTokenStream t3) ++ "]"--               -- logm $ "reallyDoIfToCase:t1++t2++t3=" ++ (show (t1++t2++t3))--               logm $ "reallyDoIfToCase:t4=[" ++ (GHC.showRichTokenStream t4) ++ "]"-               logm $ "reallyDoIfToCase:t5=[" ++ (GHC.showRichTokenStream t5) ++ "]"--               logm $ "reallyDoIfToCase:caseToks=" ++ (show caseToks)--               -- drawTokenTreeDetailed "reallyDoIfToCase"--               void $ putToksForSpan l caseToks--               -- drawTokenTree "reallyDoIfToCase after putToks"-               -- drawTokenTreeDetailed "reallyDoIfToCase after putToks"-                return newExp           inExp e = return e --- TODO: rearrange the structure and preserve the comments in the original, e.g. in e1,e2,e3-ifToCaseTransform :: GHC.Located (GHC.HsExpr GHC.Name) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name))-ifToCaseTransform (GHC.L l (GHC.HsIf _se e1 e2 e3)) = do-  trueName  <- mkNewGhcName Nothing "True"-  falseName <- mkNewGhcName Nothing "False"-  let ret = GHC.L l (GHC.HsCase e1-             (GHC.MatchGroup+-- |Actually do the transformation+ifToCaseTransform :: GHC.Located (GHC.HsExpr GHC.RdrName)+                  -> RefactGhc (GHC.Located (GHC.HsExpr GHC.RdrName))+ifToCaseTransform li@(GHC.L _ (GHC.HsIf _se e1 e2 e3)) = do+  caseLoc        <- liftT uniqueSrcSpanT -- HaRe:-1:1+  trueMatchLoc   <- liftT uniqueSrcSpanT -- HaRe:-1:2+  trueLoc1       <- liftT uniqueSrcSpanT -- HaRe:-1:3+  trueLoc        <- liftT uniqueSrcSpanT -- HaRe:-1:4+  trueRhsLoc     <- liftT uniqueSrcSpanT -- HaRe:-1:5+  falseLoc1      <- liftT uniqueSrcSpanT -- HaRe:-1:6+  falseLoc       <- liftT uniqueSrcSpanT -- HaRe:-1:7+  falseMatchLoc  <- liftT uniqueSrcSpanT -- HaRe:-1:8+  falseRhsLoc    <- liftT uniqueSrcSpanT -- HaRe:-1:9+  let trueName  = mkRdrName "True"+  let falseName = mkRdrName "False"+  let ret = GHC.L caseLoc (GHC.HsCase e1+             (GHC.MG               [-                (GHC.noLoc $ GHC.Match+                (GHC.L trueMatchLoc $ GHC.Match+                 Nothing                  [-                   GHC.noLoc $ GHC.ConPatIn (GHC.noLoc trueName) (GHC.PrefixCon [])+                   GHC.L trueLoc1 $ GHC.ConPatIn (GHC.L trueLoc trueName) (GHC.PrefixCon [])                  ]                  Nothing-                 ((GHC.GRHSs+                 (GHC.GRHSs                    [-                     GHC.noLoc $ GHC.GRHS [] e2-                   ] GHC.EmptyLocalBinds))+                     GHC.L trueRhsLoc $ GHC.GRHS [] e2+                   ] GHC.EmptyLocalBinds)                 )-              , (GHC.noLoc $ GHC.Match+              , (GHC.L falseMatchLoc $ GHC.Match+                 Nothing                  [-                   GHC.noLoc $ GHC.ConPatIn (GHC.noLoc falseName) (GHC.PrefixCon [])+                   GHC.L falseLoc1 $ GHC.ConPatIn (GHC.L falseLoc falseName) (GHC.PrefixCon [])                  ]                  Nothing-                 ((GHC.GRHSs+                 (GHC.GRHSs                    [-                     GHC.noLoc $ GHC.GRHS [] e3-                   ] GHC.EmptyLocalBinds))+                     GHC.L falseRhsLoc $ GHC.GRHS [] e3+                   ] GHC.EmptyLocalBinds)                 )-              ] undefined))-  return ret-ifToCaseTransform x = return x+              ] [] GHC.placeHolderType GHC.FromSource)) --- ----------------------------------------------------------------------{--HsIf (Maybe (SyntaxExpr id)) (LHsExpr id) (LHsExpr id) (LHsExpr id)+  oldAnns <- liftT $ getAnnsT+  let annIf   = gfromJust "Case.annIf"   $ getAnnotationEP li oldAnns+  let annThen = gfromJust "Case.annThen" $ getAnnotationEP e2 oldAnns+  let annElse = gfromJust "Case.annElse" $ getAnnotationEP e3 oldAnns+  logm $ "Case:annIf="   ++ show annIf+  logm $ "Case:annThen=" ++ show annThen+  logm $ "Case:annElse=" ++ show annElse -[Can ignore The SyntaxExpr]+  -- AZ:TODO: under some circumstances the GRHS annotations need LineSame, in others LineChanged.+  let ifDelta     = gfromJust "Case.ifDelta"     $ lookup (G GHC.AnnIf) (annsDP annIf)+  -- let ifSpanEntry = gfromJust "Case.ifSpanEntry" $ lookup (AnnSpanEntry) (annsDP annIf)+  let anne2' =+        [+          ( AnnKey caseLoc       (CN "HsCase"),   annIf { annsDP = [ (G GHC.AnnCase, ifDelta)+                                                                 , (G GHC.AnnOf,     DP (0,1))]+                                                        } )+        -- , ( AnnKey caseVirtualLoc (CN "(:)"),     Ann (DP (1,newCol)) (ColDelta newCol) (DP (1,newCol)) [] [(DP (1,0))])+        , ( AnnKey trueMatchLoc  (CN "Match"),    Ann (DP (1,2)) [] [] [] Nothing Nothing )+        , ( AnnKey trueLoc1      (CN "ConPatIn"), Ann (DP (0,0)) [] [] [] Nothing Nothing )+        , ( AnnKey trueLoc       (CN "Unqual"),   Ann (DP (0,0)) [] [] [(G GHC.AnnVal, DP (0,0))]  Nothing Nothing)+        , ( AnnKey trueRhsLoc    (CN "GRHS"),     Ann (DP (0,2)) [] [] [(G GHC.AnnRarrow, DP (0,0))]  Nothing Nothing) +        , ( AnnKey falseMatchLoc (CN "Match"),    Ann (DP (1,0)) [] [] []  Nothing Nothing)+        , ( AnnKey falseLoc1     (CN "ConPatIn"), Ann (DP (0,0)) [] [] []  Nothing Nothing)+        , ( AnnKey falseLoc      (CN "Unqual"),   Ann (DP (0,0)) [] [] [(G GHC.AnnVal, DP (0,0))]  Nothing Nothing)+        , ( AnnKey falseRhsLoc   (CN "GRHS"),     Ann (DP (0,1)) [] [] [(G GHC.AnnRarrow, DP (0,0))]  Nothing Nothing)+        ] -HsCase (LHsExpr id) (MatchGroup id)+  liftT $ putAnnsT (oldAnns `Map.union` (Map.fromList anne2'))+  return ret+ifToCaseTransform x = return x --}+-- --------------------------------------------------------------------- -{--Need to move to -(L {test/testdata/Case/B.hs:(9,10)-(11,17)} -                 (HsCase -                  (L {test/testdata/Case/B.hs:9:15-21} -                   (HsPar -                    (L {test/testdata/Case/B.hs:9:16-20} -                     (HsApp -                      (L {test/testdata/Case/B.hs:9:16-18} -                       (HsVar {Name: GHC.Real.odd})) -                      (L {test/testdata/Case/B.hs:9:20} -                       (HsVar {Name: x})))))) -                  (MatchGroup -                   [-                    (L {test/testdata/Case/B.hs:10:3-15} -                     (Match -                      [-                       (L {test/testdata/Case/B.hs:10:3-6} -                        (ConPatIn -                         (L {test/testdata/Case/B.hs:10:3-6} {Name: GHC.Types.True}) -                         (PrefixCon -                          [])))] -                      (Nothing) -                      (GRHSs -                       [-                        (L {test/testdata/Case/B.hs:10:11-15} -                         (GRHS -                          [] -                          (L {test/testdata/Case/B.hs:10:11-15} -                           (HsLit -                            (HsString {FastString: "Odd"})))))] -                       (EmptyLocalBinds)))),-                    (L {test/testdata/Case/B.hs:11:3-17} -                     (Match -                      [-                       (L {test/testdata/Case/B.hs:11:3-7} -                        (ConPatIn -                         (L {test/testdata/Case/B.hs:11:3-7} {Name: GHC.Types.False}) -                         (PrefixCon -                          [])))] -                      (Nothing) -                      (GRHSs -                       [-                        (L {test/testdata/Case/B.hs:11:12-17} -                         (GRHS -                          [] -                          (L {test/testdata/Case/B.hs:11:12-17} -                           (HsLit -                            (HsString {FastString: "Even"})))))] -                       (EmptyLocalBinds))))] {!type placeholder here?!})))--from -----(L {test/testdata/Case/B.hs:4:9-41} -                 (HsIf -                  (Nothing) -                  (L {test/testdata/Case/B.hs:4:12-18} -                   (HsPar -                    (L {test/testdata/Case/B.hs:4:13-17} -                     (HsApp -                      (L {test/testdata/Case/B.hs:4:13-15} -                       (HsVar {Name: GHC.Real.odd})) -                      (L {test/testdata/Case/B.hs:4:17} -                       (HsVar {Name: x})))))) -                  (L {test/testdata/Case/B.hs:4:25-29} -                   (HsLit -                    (HsString {FastString: "Odd"}))) -                  (L {test/testdata/Case/B.hs:4:36-41} -                   (HsLit -                    (HsString {FastString: "Even"})))))---}- -- EOF-- 

@@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}  module Language.Haskell.Refact.Refactoring.DupDef(duplicateDef) where@@ -8,157 +9,219 @@ import qualified GHC.SYB.Utils as SYB  import qualified GHC-import qualified OccName               as GHC+import qualified RdrName               as GHC -import Control.Monad import Data.List import Data.Maybe -import Language.Haskell.GhcMod+import qualified Language.Haskell.GhcMod as GM+import Language.Haskell.GhcMod.Internal  as GM import Language.Haskell.Refact.API +import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Transform +import System.Directory+ -- --------------------------------------------------------------------- -- | This refactoring duplicates a definition (function binding or -- simple pattern binding) at the same level with a new name provided by -- the user. The new name should not cause name clash/capture.-duplicateDef :: RefactSettings -> Cradle -> FilePath -> String -> SimpPos -> IO [FilePath]-duplicateDef settings cradle fileName newName (row,col) =-  runRefacSession settings cradle (comp fileName newName (row,col))+duplicateDef :: RefactSettings -> GM.Options -> FilePath -> String -> SimpPos -> IO [FilePath]+duplicateDef settings opts fileName newName (row,col) = do+  absFileName <- canonicalizePath fileName+  runRefacSession settings opts (comp absFileName newName (row,col))  comp :: FilePath -> String -> SimpPos      -> RefactGhc [ApplyRefacResult] comp fileName newName (row, col) = do-      if isVarId newName-        then do-                getModuleGhc fileName-                renamed <- getRefactRenamed-                parsed  <- getRefactParsed--                let (Just (modName,_)) = getModuleName parsed-                let maybePn = locToName (row, col) renamed-                case maybePn of-                  Just pn ->-                       do-                          -- refactoredMod@((_fp,ismod),(_toks',renamed')) <- applyRefac (doDuplicating pn newName) (Just modInfo) fileName-                          (refactoredMod@((_fp,ismod),(_,_toks',renamed')),_) <- applyRefac (doDuplicating pn newName) (RSFile fileName)-                          case (ismod) of-                            False -> error "The selected identifier is not a function/simple pattern name, or is not defined in this module "-                            True -> return ()+  if isVarId newName+    then+      do+        parseSourceFileGhc fileName+        renamed <- getRefactRenamed+        parsed  <- getRefactParsed+        targetModule <- getRefactTargetModule+        logm $ "DupDef.comp:got targetModule" -                          if modIsExported modName renamed-                           then do clients <- clientModsAndFiles modName-                                   logm ("DupDef: clients=" ++ (showGhc clients)) -- ++AZ++ debug-                                   refactoredClients <- mapM (refactorInClientMod (GHC.unLoc pn) modName -                                                             (findNewPName newName renamed')) clients-                                   return $ refactoredMod:refactoredClients-                           else  return [refactoredMod]-                  Nothing -> error "Invalid cursor position!"-        else error $ "Invalid new function name:" ++ newName ++ "!"+        let (Just (modName,_)) = getModuleName parsed+        let maybePn = locToName (row, col) renamed+        case maybePn of+          Just pn ->+            do+              logm $ "DupDef.comp:about to applyRefac for:pn=" ++ SYB.showData SYB.Parser 0 pn+              (refactoredMod@((_fp,_ismod),(_anns',_parsed')),(isDone,nn)) <- applyRefac (doDuplicating pn newName) (RSFile fileName)+              logm $ "DupDef.com:isDone=" ++ show isDone+              case isDone of+                DupDefFailed -> error "The selected identifier is not a function/simple pattern name, or is not defined in this module "+                DupDefLowerLevel -> return [refactoredMod]+                DupDefTopLevel -> do+                  if modIsExported modName renamed+                   then+                    do+                       logm $ "DupDef.comp:about to clientMods"+                       clients <- clientModsAndFiles targetModule+                       logm ("DupDef: clients=" ++ (showGhc clients)) -- ++AZ++ debug+                       refactoredClients <- mapM (refactorInClientMod (GHC.unLoc pn) modName nn)+                                                 clients+                       return $ refactoredMod:refactoredClients+                   else return [refactoredMod]+          Nothing -> error "Invalid cursor position!"+    else error $ "Invalid new function name:" ++ newName ++ "!"  +data DupDefResult = DupDefFailed | DupDefTopLevel | DupDefLowerLevel+                  deriving (Eq,Show)  doDuplicating :: GHC.Located GHC.Name -> String-              -> RefactGhc ()+              -> RefactGhc (DupDefResult,GHC.Name) doDuplicating pn newName = do+   logm $ "DupDef.comp:doDuplicating entered"    inscopes <- getRefactInscopes-   renamed  <- getRefactRenamed-   reallyDoDuplicating pn newName inscopes renamed+   logm $ "DupDef.comp:doDuplicating got inscopes"+   reallyDoDuplicating pn newName inscopes   reallyDoDuplicating :: GHC.Located GHC.Name -> String-              -> InScopes -> GHC.RenamedSource-              -> RefactGhc ()-reallyDoDuplicating pn newName inscopes renamed = do+              -> InScopes+              -> RefactGhc (DupDefResult,GHC.Name)+reallyDoDuplicating pn newName _inscopes = do+   clearRefactDone+   parsed <- getRefactParsed+   newNameGhc <- mkNewGhcName Nothing newName -   renamed' <- everywhereMStaged SYB.Renamer (SYB.mkM dupInMod-                                  `SYB.extM` dupInMatch-                                  `SYB.extM` dupInPat-                                  `SYB.extM` dupInLet-                                  `SYB.extM` dupInLetStmt-                                 ) renamed-   putRefactRenamed renamed'-   return ()+   -- Check if it is a top level dup+   parsed2 <- dupInModule newNameGhc parsed+   d <- getRefactDone+   if d+     then do+       putRefactParsed parsed2 emptyAnns+       return (DupDefTopLevel,newNameGhc)+     else do+       parsed' <- SYB.everywhereMStaged SYB.Parser (+                                      SYB.mkM    (dupInMatch   newNameGhc)+                                      `SYB.extM` (dupInPat     newNameGhc)+                                      `SYB.extM` (dupInLet     newNameGhc)+                                      `SYB.extM` (dupInLetStmt newNameGhc)+                                     ) parsed2+       putRefactParsed parsed' emptyAnns+       done <- getRefactDone+       if done then return (DupDefLowerLevel,newNameGhc)+               else return (DupDefFailed,newNameGhc)          where         --1. The definition to be duplicated is at top level.-        -- dupInMod :: (GHC.HsGroup GHC.Name)-> RefactGhc (GHC.HsGroup GHC.Name)-        dupInMod (grp :: (GHC.HsGroup GHC.Name))-          | not $ emptyList (findFunOrPatBind pn (hsBinds grp)) = doDuplicating' inscopes grp pn-        dupInMod grp = return grp+        dupInModule :: GHC.Name -> GHC.ParsedSource -> RefactGhc GHC.ParsedSource+        dupInModule newNameGhc p+          = do+              declsp <- liftT $ hsDecls p+              nm <- getRefactNameMap+              if not $ emptyList (findFunOrPatBind nm pn declsp)+                then doDuplicating' newNameGhc p pn+                else return p          --2. The definition to be duplicated is a local declaration in a match-        dupInMatch (match@(GHC.Match _pats _typ rhs)::GHC.Match GHC.Name)-          | not $ emptyList (findFunOrPatBind pn (hsBinds rhs)) = doDuplicating' inscopes match pn-        dupInMatch match = return match+        dupInMatch newNameGhc (match::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))+          = do+              nm <- getRefactNameMap+              declsp <- liftT $ hsDecls match+              logm $ "dupInMatch:declsp=" ++ showGhc declsp+              if not $ emptyList (findFunOrPatBind nm pn declsp)+                then doDuplicating' newNameGhc match pn+                else return match          --3. The definition to be duplicated is a local declaration in a pattern binding-        dupInPat (pat@(GHC.PatBind _p rhs _typ _fvs _) :: GHC.HsBind GHC.Name)-          | not $ emptyList (findFunOrPatBind pn (hsBinds rhs)) = doDuplicating' inscopes pat pn-        dupInPat pat = return pat+        dupInPat newNameGhc (pat@(GHC.L _ (GHC.ValD (GHC.PatBind _p _rhs _typ _fvs _))) :: GHC.LHsDecl GHC.RdrName)+          = do+            logm $ "dupInPat hit"+            doDuplicating' newNameGhc pat pn+        dupInPat _ pat = return pat          --4: The defintion to be duplicated is a local decl in a Let expression-        dupInLet (letExp@(GHC.HsLet ds _e):: GHC.HsExpr GHC.Name)-          | not $ emptyList (findFunOrPatBind pn (hsBinds ds)) = doDuplicating' inscopes letExp pn-        dupInLet letExp = return letExp+        dupInLet newNameGhc (letExp@(GHC.L _ (GHC.HsLet _ds _e)):: GHC.LHsExpr GHC.RdrName)+          = doDuplicating' newNameGhc letExp pn+        dupInLet _ letExp = return letExp          --5. The definition to be duplicated is a local decl in a case alternative.         -- Note: The local declarations in a case alternative are covered in #2 above.          --6.The definition to be duplicated is a local decl in a Let statement.-        dupInLetStmt (letStmt@(GHC.LetStmt ds):: GHC.Stmt GHC.Name)-           -- was |findFunOrPatBind pn ds /=[]=doDuplicating' inscps letStmt pn-           |not $ emptyList (findFunOrPatBind pn (hsBinds ds)) = doDuplicating' inscopes letStmt pn-        dupInLetStmt letStmt = return letStmt+        dupInLetStmt newNameGhc (letStmt@(GHC.L _ (GHC.LetStmt _ds)):: GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName))+          = doDuplicating' newNameGhc letStmt pn+        dupInLetStmt _ letStmt = return letStmt  -        -- findFunOrPatBind :: (SYB.Data t) => GHC.Located GHC.Name -> t -> [GHC.LHsBind GHC.Name]-        findFunOrPatBind (GHC.L _ n) ds = filter (\d->isFunBindR d || isSimplePatBind d) $ definingDeclsNames [n] ds True False+        findFunOrPatBind nm (GHC.L _ n) ds+          = filter (\d->isFunBindP d || isSimplePatDecl d) $ definingDeclsRdrNames nm [n] ds True False  -        doDuplicating' :: (HsValBinds t) => InScopes -> t -> GHC.Located GHC.Name-                       -> RefactGhc (t)-        doDuplicating' _inscps parentr ln@(GHC.L _ n)-           = do let-                    declsr = hsBinds parentr+        doDuplicating' :: (SYB.Typeable t,SYB.Data t) => GHC.Name -> t -> GHC.Located GHC.Name -> RefactGhc t+        doDuplicating' newNameGhc t _ln = do+          logm $ "doDuplicating' entered"+          -- logm $ "doDuplicating' entered:t=" ++ SYB.showData SYB.Parser 0 t+          -- declsp <- liftT $ hsDecls t+          declsp <- liftT $ hsDeclsGeneric t+          nm <- getRefactNameMap+          if not $ emptyList (findFunOrPatBind nm pn declsp)+            then doDuplicating'' newNameGhc t pn+            else return t -                    duplicatedDecls = definingDeclsNames [n] declsr True False-                    -- (after,before)  = break (definesP pn) (reverse declsp) -                (f,d) <- hsFDNamesFromInside parentr+        doDuplicating'' :: (SYB.Data t) => GHC.Name -> t -> GHC.Located GHC.Name+                       -> RefactGhc t+        doDuplicating'' newNameGhc parentr ln = do+          logm $ "doDuplicating'':parentr=" ++ SYB.showData SYB.Parser 0 parentr+          r <- hasDeclsSybTransform workerHsDecls workerBind parentr+          logm $ "doDuplicating'':done"+          return r+          where+              workerHsDecls :: forall t. HasDecls t => t -> RefactGhc t+              workerHsDecls t = do+                logm $ "workerHsDecls hit"+                ds <- liftT $ hsDecls t+                ds' <- doDuplicating3 newNameGhc parentr ln ds+                liftT $ replaceDecls t ds'++              workerBind :: (GHC.LHsBind GHC.RdrName -> RefactGhc (GHC.LHsBind GHC.RdrName))+              workerBind t@(GHC.L _ (GHC.PatBind{})) = do+                logm $ "workerBind hit"+                ds <- liftT $ hsDeclsPatBind t+                ds' <- doDuplicating3 newNameGhc t ln ds+                liftT $ replaceDeclsPatBind t ds'+              workerBind x = error $ "DupDef.doDuplicating'':workerBind got:" ++ showGhc x++        doDuplicating3 :: (SYB.Data t) => GHC.Name -> t -> GHC.Located GHC.Name+                       -> [GHC.LHsDecl GHC.RdrName]+                       -> RefactGhc [GHC.LHsDecl GHC.RdrName]+        doDuplicating3 newNameGhc parentr ln@(GHC.L _ n) declsp+           = do+                logm $ "doDuplicating'' entered:ln" ++ showGhc ln+                -- declsp <- liftT $ hsDecls parentr+                nm <- getRefactNameMap+                let+                    duplicatedDecls = definingDeclsRdrNames nm [n] declsp True False++                logm $ "doDuplicating'':duplicatedDecls=" ++ showGhc duplicatedDecls+                (f,d) <- hsFDNamesFromInsideRdr parentr                     --f: names that might be shadowd by the new name,                     --d: names that might clash with the new name -                dv <- hsVisibleNames ln declsr --dv: names may shadow new name-                let vars        = nub (f `union` d `union` dv)+                logm $ "doDuplicating'':(f,d)=" ++ show (f,d)+                dv <- hsVisiblePNsRdr nm ln declsp --dv: names may shadow new name+                let vars        = nub (f `union` d `union` map showGhc dv) -                newNameGhc <- mkNewGhcName Nothing newName                 -- TODO: Where definition is of form tup@(h,t), test each element of it for clashes, or disallow                 nameAlreadyInScope <- isInScopeAndUnqualifiedGhc newName Nothing -                -- logm ("DupDef: nameAlreadyInScope =" ++ (show nameAlreadyInScope)) -- ++AZ++ debug-                -- logm ("DupDef: ln =" ++ (show ln)) -- ++AZ++ debug--                if elem newName vars || (nameAlreadyInScope && findEntity ln duplicatedDecls) +                if elem newName vars || (nameAlreadyInScope && findEntity ln duplicatedDecls)                    then error ("The new name'"++newName++"' will cause name clash/capture or ambiguity problem after "                                ++ "duplicating, please select another name!")-                   else do newBinding <- duplicateDecl declsr parentr n newNameGhc-                           -- let newDecls = replaceDecls declsr (declsr ++ newBinding)-                           let newDecls = replaceBinds declsr (declsr ++ newBinding)-                           return $ replaceBinds parentr newDecls------ | Find the the new definition name in GHC.Name format.-findNewPName :: String -> GHC.RenamedSource -> GHC.Name-findNewPName name renamed = gfromJust "findNewPName" res-  where-     res = somethingStaged SYB.Renamer Nothing-            (Nothing `SYB.mkQ` worker) renamed--     worker  (pname::GHC.Name)-        | (GHC.occNameString $ GHC.getOccName pname) == name = Just pname-     worker _ = Nothing+                   else do+                           setRefactDone+                           newdecls <- duplicateDecl declsp n newNameGhc+                           -- parentr' <- liftT $ replaceDecls parentr newdecls+                           -- return parentr'+                           return newdecls   -- | Do refactoring in the client module. That is to hide the@@ -166,31 +229,26 @@ -- the client module. refactorInClientMod :: GHC.Name -> GHC.ModuleName -> GHC.Name -> TargetModule                     -> RefactGhc ApplyRefacResult-refactorInClientMod oldPN serverModName newPName targetModule@(_,modSummary)+refactorInClientMod oldPN serverModName newPName targetModule   = do-       logm ("refactorInClientMod: (serverModName,newPName)=" ++ (showGhc (serverModName,newPName))) -- ++AZ++ debug-       void $ activateModule targetModule+       logm ("refactorInClientMod: (oldPN,serverModName,newPName)=" ++ (showGhc (oldPN,serverModName,newPName)))+       -- void $ activateModule targetModule+       getTargetGhc targetModule -       let fileName = gfromJust "refactorInClientMod" $ GHC.ml_hs_file $ GHC.ms_location modSummary-{--       -- modInfo@(t,ts) <- getModuleGhc fileName-       getModuleGhc fileName--}+       let fileName = GM.mpPath targetModule        renamed <- getRefactRenamed        parsed <- getRefactParsed         let modNames = willBeUnQualImportedBy serverModName renamed        logm ("refactorInClientMod: (modNames)=" ++ (showGhc (modNames))) -- ++AZ++ debug -       -- if isJust modNames && needToBeHided (pNtoName newPName) exps parsed        mustHide <- needToBeHided newPName renamed parsed        logm ("refactorInClientMod: (mustHide)=" ++ (showGhc (mustHide))) -- ++AZ++ debug        if isJust modNames && mustHide         then do-                -- refactoredMod <- applyRefac (doDuplicatingClient serverModName [newPName]) (Just modInfo) fileName                 (refactoredMod,_) <- applyRefac (doDuplicatingClient serverModName [newPName]) (RSFile fileName)                 return refactoredMod-        else return ((fileName,unmodified),([],[],renamed))+        else return ((fileName,RefacUnmodifed),(emptyAnns,parsed))    where      needToBeHided :: GHC.Name -> GHC.RenamedSource -> GHC.ParsedSource -> RefactGhc Bool      needToBeHided name exps parsed = do@@ -201,9 +259,10 @@ doDuplicatingClient :: GHC.ModuleName -> [GHC.Name]               -> RefactGhc () doDuplicatingClient serverModName newPNames = do-  renamed  <- getRefactRenamed-  renamed' <- addHiding serverModName renamed newPNames-  putRefactRenamed renamed'+  logm $ "doDuplicatingClient:newPNames=" ++ showGhc newPNames+  parsed  <- getRefactParsed+  parsed' <- addHiding serverModName parsed (map GHC.nameRdrName newPNames)+  putRefactParsed parsed' emptyAnns   return ()  @@ -214,7 +273,7 @@ willBeUnQualImportedBy :: GHC.ModuleName -> GHC.RenamedSource -> Maybe [GHC.ModuleName] willBeUnQualImportedBy modName (_,imps,_,_)    = let-         ms = filter (\(GHC.L _ (GHC.ImportDecl (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as h))+         ms = filter (\(GHC.L _ (GHC.ImportDecl _ (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as h))                     -> modName == modName1                        && not isQualified                               && (isNothing h  -- not hiding@@ -225,8 +284,7 @@          in if (emptyList ms) then Nothing                       else Just $ nub $ map getModName ms -         where getModName (GHC.L _ (GHC.ImportDecl _modName1 _qualify _source _safe _isQualified _isImplicit as _h))+         where getModName (GHC.L _ (GHC.ImportDecl _ _modName1 _qualify _source _safe _isQualified _isImplicit as _h))                  = if isJust as then (fromJust as)                                 else modName-               -- simpModName (SN m loc) = m 

@@ -1,1800 +1,1655 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}--module Language.Haskell.Refact.Refactoring.MoveDef-  ( liftToTopLevel-  , liftOneLevel-  , demote-  -- ,liftingInClientMod-  ) where--import qualified Data.Generics as SYB-import qualified GHC.SYB.Utils as SYB---- import qualified DynFlags      as GHC-import qualified Exception             as GHC-import qualified FastString            as GHC-import qualified GHC                   as GHC-import qualified Name                  as GHC-import qualified Outputable            as GHC-import qualified TyCon                 as GHC-import qualified TypeRep               as GHC-import qualified Var                   as Var--import Control.Exception-import Control.Monad.State-import qualified Data.Generics.Zipper as Z-import Data.List-import Data.Maybe--import Language.Haskell.GhcMod-import Language.Haskell.Refact.API--import Data.Generics.Strafunski.StrategyLib.StrategyLib---- import Debug.Trace---- ------------------------------------------------------------------------- data Direction = UptoTopLevel | UpOneLevel | Down--{--------This function handles refactorings involving moving a definition---------- According to the Haskell's syntax, a declaration may occur in one of-the following six contexts:--  1. A top level declaration in the module:-        old: HsModule SrcLoc ModuleName (Maybe [HsExportSpecI i]) [HsImportDeclI i] ds-        new: (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], Maybe LHsDocString)-              HsGroup hs_valds :: HsValBinds id ...--  2. A local declaration in a Match: (of a FunBind)-        old: HsMatch SrcLoc i [p] (HsRhs e) ds-        new: Match [LPat id] (Maybe (LHsType id)) (GRHSs id)--  3. A local declaration in a pattern binding:-        old: HsPatBind SrcLoc p (HsRhs e) ds-        new: PatBind (LPat idL) (GRHSs idR) PostTcType NameSet (Maybe tickish)--  4. A local declaration in a Let expression:-        old: HsLet ds e-        new: HsLet (HsLocalBinds id) (LHsExpr id)--  5. A local declaration in a Case alternative:-        old: HsAlt SrcLoc p (HsRhs e) ds-        new: HsCase (LHsExpr id) (MatchGroup id)-           new is same as in a FunBind.--  6. A local declaration in a Do statement:-        old: HsLetStmt ds (HsStmt e p ds)-        new: LetStmt (HsLocalBindsLR idL idR)-             in context GRHS [LStmt id] (LHsExpr id)--}---- | Lift a definition to the top level-liftToTopLevel :: RefactSettings -> Cradle -> FilePath -> SimpPos -> IO [FilePath]-liftToTopLevel settings cradle fileName (row,col) =-  runRefacSession settings cradle (compLiftToTopLevel fileName (row,col))---compLiftToTopLevel :: FilePath -> SimpPos-     -> RefactGhc [ApplyRefacResult]-compLiftToTopLevel fileName (row,col) = do-      getModuleGhc fileName-      renamed <- getRefactRenamed-      parsed  <- getRefactParsed--      let (Just (modName,_)) = getModuleName parsed-      let maybePn = locToName (row, col) renamed-      case maybePn of-        Just pn ->  do-            liftToTopLevel' modName pn-        _       ->  error "\nInvalid cursor position!\n"----- ------------------------------------------------------------------------- | Move a definition one level up from where it is now-liftOneLevel :: RefactSettings -> Cradle -> FilePath -> SimpPos -> IO [FilePath]-liftOneLevel settings cradle fileName (row,col) =-  runRefacSession settings cradle (compLiftOneLevel fileName (row,col))---compLiftOneLevel :: FilePath -> SimpPos-     -> RefactGhc [ApplyRefacResult]-compLiftOneLevel fileName (row,col) = do-      getModuleGhc fileName-      renamed <- getRefactRenamed-      parsed  <- getRefactParsed--      -- logm $ "compLiftOneLevel:(fileName,row,col)="++(show (fileName,row,col))-      -- logm $ "compLiftOneLevel:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++--      let (Just (modName,_)) = getModuleName parsed-      let maybePn = locToName (row, col) renamed-      case maybePn of-        Just pn ->  do-            rs <- liftOneLevel' modName pn-            logm $ "compLiftOneLevel:rs=" ++ (show $ (refactDone rs,map (\((_,d),_) -> d) rs))-            if (refactDone rs)-              then return rs-              else error ( "Lifting this definition failed. "++-                       " This might be because that the definition to be "++-                       "lifted is defined in a class/instance declaration.")-        _       ->  error "\nInvalid cursor position!\n"------ ------------------------------------------------------------------------- | Move a definition one level down-demote :: RefactSettings -> Cradle -> FilePath -> SimpPos -> IO [FilePath]-demote settings cradle fileName (row,col) =-  runRefacSession settings cradle (compDemote fileName (row,col))--compDemote ::FilePath -> SimpPos-         -> RefactGhc [ApplyRefacResult]-compDemote fileName (row,col) = do-      getModuleGhc fileName-      renamed <- getRefactRenamed-      parsed  <- getRefactParsed--      -- TODO: make the next one an API call, that also gets the-      -- parsed source-      let (Just (modName,_)) = getModuleName parsed-      let maybePn = locToName (row, col) renamed-      case maybePn of-        Just pn -> do-          demote' modName pn-        _       -> error "\nInvalid cursor position!\n"---{--demote args- = do let  fileName = ghead "filename"  args-           row = read (args!!1)::Int-           col = read (args!!2)::Int-      modName <- fileNameToModName fileName-      (inscps, _, mod, toks) <- parseSourceFile fileName-      let pnt = locToPNT fileName (row, col) mod-          pn = pNTtoPN pnt-      if pn /= defaultPN-         then demote' modName fileName (mod, toks) pn-         else error "\nInvalid cursor position!\n"--move direction args-  = do let fileName = ghead "filename"  args-           row = read (args!!1)::Int-           col = read (args!!2)::Int-       modName <- fileNameToModName fileName-       (inscps, _, mod, toks) <- parseSourceFile fileName-       let pnt = locToPNT fileName (row, col) mod-           pn = pNTtoPN pnt-       if pn /= defaultPN-         then-          case direction  of-               UptoTopLevel ->liftToTopLevel' modName fileName (inscps, mod, toks) pnt-               UpOneLevel   ->liftOneLevel'   modName fileName (inscps, mod, toks) pnt-               Down         ->demote'         modName fileName (mod, toks)  pn-          else error "\nInvalid cursor position!\n"---{- Refactoring Names: 'liftToTopLevel'--   This refactoring lifts a local function/pattern binding to the top-   level of the module, so as to make it accessible to other functions in-   the current module, and those modules that import current module.--   In the current implementation, a definition will be lifted only if-   none of the identifiers defined in this definition will cause name-   clash/capture problems in the current module after lifting.--   In the case that the whole current module is exported implicitly,-   the lifted identifier will be exported automatically after lifting. If-   the identifier will cause name clash/ambiguous occurrence problem in a-   client module, it will be hided in the import declaration of the-   client module (Note: this might not be the best solution, we prefer-   hiding it in the server module instead of in the client module in the-   final version).--   In the case of indirect importing, it might be time-consuming to-   trace whether the lifted identifier will cause any problem in a client-   module that indirectly imports the current module. The current-   solution is: suppose a defintion is lifted to top level in module A,-   and module A is imported and exported by module B, then the lifted-   identifier will be hided in the import declaration of B no matter-  whether it causes problems in module B or not.--   Function name: liftToTopLevel-   parameters: fileName--current file name.-               mod -- the scoped abstract syntax tree of the module.-               pn  -- the function/pattern name to be lifted.--}---}--liftToTopLevel' :: GHC.ModuleName -- -> (ParseResult,[PosToken]) -> FilePath-                -> GHC.Located GHC.Name-                -> RefactGhc [ApplyRefacResult]-liftToTopLevel' modName pn@(GHC.L _ n) = do-  renamed <- getRefactRenamed-  -- logm $ "liftToTopLevel':renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++-  logm $ "liftToTopLevel':pn=" ++ (showGhc pn)-  if isLocalFunOrPatName n renamed-      then do-              (refactoredMod,declPns) <- applyRefac (liftToMod) RSAlreadyLoaded--              logm $ "liftToTopLevel' applyRefac done "-              -- logm $ "liftToTopLevel' applyRefac done:toks= " ++ (show (fst $ snd refactoredMod))--              if modIsExported modName renamed-               then do clients <- clientModsAndFiles modName-                       logm $ "liftToTopLevel':(clients,declPns)=" ++ (showGhc (clients,declPns))-                       refactoredClients <- mapM (liftingInClientMod modName declPns) clients-                       return (refactoredMod:(concat refactoredClients))-               else do return [refactoredMod]-      else error "\nThe identifier is not a local function/pattern name!"--    where-       {-step1: divide the module's top level declaration list into three parts:-         'parent' is the top level declaration containing the lifted declaration,-         'before' and `after` are those declarations before and after 'parent'.-         step2: get the declarations to be lifted from parent, bind it to liftedDecls -         step3: remove the lifted declarations from parent and extra arguments may be introduce.-         step4. test whether there are any names need to be renamed.-       -}-       liftToMod = do-         renamed <- getRefactRenamed-         let declsr = hsBinds renamed-         let (before,parent,after) = divideDecls declsr pn-         -- error ("liftToMod:(before,parent,after)=" ++ (showGhc (before,parent,after))) -- ++AZ++-         {- ++AZ++ : hsBinds does not return class or instance definitions-         when (isClassDecl $ ghead "liftToMod" parent)-               $ error "Sorry, the refactorer cannot lift a definition from a class declaration!"-         when (isInstDecl $ ghead "liftToMod" parent)-               $ error "Sorry, the refactorer cannot lift a definition from an instance declaration!"-         -}-         let liftedDecls = definingDeclsNames [n] parent True True-             declaredPns = nub $ concatMap definedPNs liftedDecls-             liftedSigs = definingSigsNames [n] parent-             mLiftedSigs = listToMaybe liftedSigs--         -- TODO: what about declarations between this-         -- one and the top level that are used in this one?--         -- logm $ "liftToMod:(liftedDecls,declaredPns)=" ++ (showGhc (liftedDecls,declaredPns))-         -- original : pns<-pnsNeedRenaming inscps mod parent liftedDecls declaredPns-         pns <- pnsNeedRenaming renamed parent liftedDecls declaredPns--         -- (_,dd) <- hsFreeAndDeclaredPNs renamed-         let dd = getDeclaredVars $ hsBinds renamed-         logm $ "liftToMod:(ddd)=" ++ (showGhc dd)--         -- drawTokenTree "liftToMod.a"-         drawTokenTreeDetailed "liftToMod.a"--         if pns==[]-           then do-             -- TODO: change the order, first move the decls then add params,-             --       else the liftedDecls get mangled while still in the parent-             (parent',liftedDecls',_mLiftedSigs') <- addParamsToParentAndLiftedDecl n dd parent liftedDecls mLiftedSigs-             -- let liftedDecls''=if paramAdded then filter isFunOrPatBindR liftedDecls'-             --                                 else liftedDecls'--             -- drawTokenTree "liftToMod.c"-             -- logm $ "liftToMod:(declaredPns)=" ++ (showGhc declaredPns)-             -- logm $ "liftToMod:(liftedDecls')=" ++ (showGhc liftedDecls')--             let renamed' = replaceBinds renamed (before++parent'++after)-                 defName  = (ghead "liftToMod" (definedPNs (ghead "liftToMod2" parent')))-             void $ moveDecl1 renamed'-                    (Just defName)-                    [GHC.unLoc pn] (Just liftedDecls') declaredPns True--             -- drawTokenTree "liftToMod.b"--             return declaredPns--           else askRenamingMsg pns "lifting"------ -----------------------------------------------------------------------moveDecl1 :: (HsValBinds t)-  => t -- ^ The syntax element to update-  -> Maybe GHC.Name -- ^ If specified, add defn after this one--     -- TODO: make this next parameter a single value, not a list,-     -- after module complete-  -> [GHC.Name]     -- ^ The first one is the decl to move-  -> Maybe [GHC.LHsBind GHC.Name]-  -> [GHC.Name]     -- ^ The signatures to remove. May be multiple if-                    --   decl being moved has a patbind.-  -> Bool           -- ^ True if moving to the top level-  -> RefactGhc t    -- ^ The updated syntax element (and tokens in monad)-moveDecl1 t defName ns mliftedDecls sigNames topLevel = do--  -- TODO: work with all of ns, not just the first-  let n = ghead "moveDecl1" ns-  let funBinding = case mliftedDecls of-        Nothing -> definingDeclsNames' [n] t-        Just liftedDecls -> liftedDecls--  let Just sspan = getSrcSpan funBinding-  funToks <- getToksForSpan sspan--  (t'',sigsRemoved) <- rmTypeSigs sigNames t-  (t',_declRemoved,_sigRemoved)  <- rmDecl (ghead "moveDecl3.1"  ns) False t''--  let getToksForMaybeSig (GHC.L ss _) =-                       do-                         sigToks <- getToksForSpan ss-                         return sigToks--  maybeToksSigMulti <- mapM getToksForMaybeSig-                       $ sortBy (\(GHC.L s1 _) (GHC.L s2 _) -> compare (ghcSrcSpanToForestSpan s1) (ghcSrcSpanToForestSpan s2))-                          sigsRemoved-  let maybeToksSig = concat maybeToksSigMulti--  r <- addDecl t' defName (ghead "moveDecl1 2" funBinding,sigsRemoved,Just (maybeToksSig ++ funToks)) topLevel--  return r---askRenamingMsg :: [GHC.Name] -> String -> t-askRenamingMsg pns str-  = error ("The identifier(s): " ++ (intercalate "," $ map showPN pns) ++-           " will cause name clash/capture or ambiguity occurrence problem after "-           ++ str ++", please do renaming first!")--  where-    showPN pn = showGhc (pn,GHC.nameSrcLoc pn)---- |Get the subset of 'pns' that need to be renamed before lifting.-pnsNeedRenaming :: (SYB.Data t1) =>-  t1 -> [GHC.LHsBind GHC.Name] -> t2 -> [GHC.Name]-  -> RefactGhc [GHC.Name]-pnsNeedRenaming dest parent _liftedDecls pns-   =do-       r <- mapM pnsNeedRenaming' pns-       return (concat r)-  where-     pnsNeedRenaming' pn-       = do-            (f,d) <- hsFDsFromInside dest --f: free variable names that may be shadowed by pn-                                             --d: declaread variables names that may clash with pn-            vs <- hsVisiblePNs pn parent  --vs: declarad variables that may shadow pn-            let -- inscpNames = map (\(x,_,_,_)->x) $ inScopeInfo inscps-                vars = map pNtoName (nub (f `union` d `union` vs) \\ [pn]) -- `union` inscpNames-            -- if elem (pNtoName pn) vars  || isInScopeAndUnqualified (pNtoName pn) inscps && findEntity pn dest-            isInScope <- isInScopeAndUnqualifiedGhc (pNtoName pn) Nothing-            logm $ "MoveDef.pnsNeedRenaming:(f,d,vs,vars,isInScope)=" ++ (showGhc (f,d,vs,vars,isInScope))-            if elem (pNtoName pn) vars  || isInScope && findEntity pn dest-               then return [pn]-               else return []-     --This pNtoName takes into account the qualifier.-     pNtoName = showGhc---addParamsToParent :: (HsValBinds t) => GHC.Name -> [GHC.Name] -> t -> RefactGhc t-addParamsToParent _pn [] t = return t-addParamsToParent  pn params t = do-  logm $ "addParamsToParent:(pn,params)" ++ (showGhc (pn,params))-  addActualParamsToRhs True pn params t----- |Do refactoring in the client module. that is to hide the identifer--- in the import declaration if it will cause any problem in the--- client module.-liftingInClientMod :: GHC.ModuleName -> [GHC.Name] -> TargetModule-  -> RefactGhc [ApplyRefacResult]-liftingInClientMod serverModName pns targetModule@(_,modSummary) = do-       void $ activateModule targetModule-       renamed <- getRefactRenamed-       -- logm $ "liftingInClientMod:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++-       let clientModule = GHC.ms_mod modSummary-       logm $ "liftingInClientMod:clientModule=" ++ (showGhc clientModule)-  -- = do (inscps, exps ,mod ,ts) <- parseSourceFile fileName-       -- let modNames = willBeUnQualImportedBy serverModName mod-       modNames <- willBeUnQualImportedBy serverModName-       logm $ "liftingInClientMod:modNames=" ++ (showGhc modNames)-       if isJust modNames-        then do-             pns' <- namesNeedToBeHided clientModule (gfromJust "liftingInClientMod" modNames) pns-             logm $ "liftingInClientMod:pns'=" ++ (showGhc pns')-             -- in if pns' /= []-             if (nonEmptyList pns')-                 -- then do <-runStateT (addHiding serverModName mod pns') ((ts,unmodified),(-1000,0))-                 then do (refactoredMod,_) <- applyRefac (addHiding serverModName renamed pns') RSAlreadyLoaded-                         return [refactoredMod]-                 else return []-        else return []---- |Test whether an identifier defined in the modules specified by--- 'names' will be exported by current module.-willBeExportedByClientMod :: [GHC.ModuleName] -> GHC.RenamedSource -> Bool-willBeExportedByClientMod names renamed =-  let (_,_,exps,_) = renamed-  in if isNothing exps-        then False-        else any isJust $ map (\y-> (find (\x-> (simpModule x==Just y)) (gfromJust "willBeExportedByClientMod" exps))) names-     where simpModule (GHC.L _ (GHC.IEModuleContents m)) = Just m-           simpModule _  = Nothing---- |get the module name or alias name by which the lifted identifier--- will be imported automatically.--- TODO: maybe move this into TypeUtils--- willBeUnQualImportedBy::HsName.ModuleName->HsModuleP->Maybe [HsName.ModuleName]-willBeUnQualImportedBy :: GHC.ModuleName -> RefactGhc (Maybe [GHC.ModuleName])-willBeUnQualImportedBy modName = do-   (_,imps,_,_) <- getRefactRenamed-   let ms = filter (\(GHC.L _ (GHC.ImportDecl (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as h))-                     -> modName == modName1 && (not isQualified) && (isNothing h || (isJust h && ((fst (fromJust h)) == True))))-                   imps--       res = if (emptyList ms) then Nothing-                               else Just $ nub $ map getModName ms--       getModName (GHC.L _ (GHC.ImportDecl (GHC.L _ modName2) _qualify _source _safe _isQualified _isImplicit as _h))-        = if isJust as then simpModName (fromJust as)-                       else modName2--       simpModName m = m--   logm $ "willBeUnQualImportedBy:(ms,res)=" ++ (showGhc (ms,res))--   return res----- |get the subset of 'pns', which need to be hided in the import--- declaration in module 'mod'--- Note: these are newly exported from the module, so we cannot use--- the GHC name resolution i nthis case.-namesNeedToBeHided :: GHC.Module -> [GHC.ModuleName] -> [GHC.Name]-   -> RefactGhc [GHC.Name]-namesNeedToBeHided clientModule modNames pns = do-  renamed <- getRefactRenamed-  parsed <- getRefactParsed-  logm $ "namesNeedToBeHided:willBeExportedByClientMod=" ++ (show $ willBeExportedByClientMod modNames renamed)-  gnames <- GHC.getNamesInScope-  let clientInscopes = filter (\n -> clientModule == GHC.nameModule n) gnames-  logm $ "namesNeedToBeHided:(clientInscopes)=" ++ (showGhc (clientInscopes))--  pnsMapped <- mapM getLocalEquiv pns-  logm $ "namesNeedToBeHided:pnsMapped=" ++ (showGhc pnsMapped)--  let pnsMapped' = filter (\(_,_,ns) -> not $ emptyList ns) pnsMapped--  if willBeExportedByClientMod modNames renamed-      then return pns-      else do-        ff <- mapM (needToBeHided parsed) pnsMapped'-        return $ concat ff-  where-    -- | Strip the package prefix from the name and return the-    -- stripped name together with any names in the local module that-    -- may match the stripped one-    getLocalEquiv :: GHC.Name -> RefactGhc (GHC.Name,String,[GHC.Name])-    getLocalEquiv pn = do-      let pnStr = stripPackage $ showGhc pn-      logm $ "MoveDef getLocalEquiv: about to parseName:" ++ (show pnStr)-      ecns <- GHC.gtry $ GHC.parseName pnStr-      let cns = case ecns of-                 Left (_e::SomeException) -> []-                 Right v -> v-      logm $ "MoveDef getLocalEquiv: cns:" ++ (showGhc cns)-      return (pn,pnStr,cns)--    stripPackage :: String -> String-    stripPackage str = reverse s-      where-        (s,_) = break (== '.') $ reverse str--    needToBeHided :: GHC.ParsedSource -> (GHC.Name,String,[GHC.Name]) -> RefactGhc [GHC.Name]-    needToBeHided parsed (pn,_pnStr,pnsLocal) = do-      let uwoq = map (\n -> usedWithoutQualR n parsed) pnsLocal--      -- logm $ "needToBeHided:(hsBinds renamed)=" ++ (showGhc (hsBinds renamed))-      logm $ "needToBeHided:(pn,uwoq)=" ++ (showGhc (pn,uwoq))--      if (any (== True) uwoq --the same name is used in the module unqualifiedly or-                --is exported unqualifiedly by an Ent decl--            -- was || causeNameClashInExports pn modNames renamed)-            -- TODO: ++AZ++ check if next line needs to be reinstated-            -- was || any (\m -> causeNameClashInExports oldPN pn m renamed) modNames)-            || False)-           then return [pn]-           else return []----- **************************************************************************************************************----{- Refactoring Names: 'liftOneLevel'-   Descritption:-    this refactoring lifts a local function/pattern binding only one level up.-    By 'lifting one-level up' ,I mean:--    case1: In a module (HsModule SrcLoc ModuleName (Maybe [HsExportSpecI i]) [HsImportDeclI i] ds):-           A local declaration D  will be lifted to the same level as the 'ds', if D is in the -           where clause of one of ds's element declaration.--        new: (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], Maybe LHsDocString)-              HsGroup hs_valds :: HsValBinds id ...----    case2: In a match ( HsMatch SrcLoc i [p] (HsRhs e) ds) :-          A local declaration D  will be lifted to the same level as the 'ds', if D is in the -           where clause of one of ds's element declaration.-           A declaration D,say,in the rhs expression 'e' will be lifted to 'ds' if D is Not local to-           other declaration list in 'e'--           (in a FunBind)-        new: Match [LPat id] (Maybe (LHsType id)) (GRHSs id)---    case3: In a pattern  binding (HsPatBind SrcLoc p (HsRhs e) ds):-           A local declaration D  will be lifted to the same level as the 'ds', if D is in the -           where clause of one of ds's element declaration.-           A declaration D,say,in the rhs expression 'e' will be lifted to 'ds' if D is Not local to-           other declaration list in 'e'--        new: PatBind (LPat idL) (GRHSs idR) PostTcType NameSet (Maybe tickish)----    case4: In the Let expression (Exp (HsLet ds e):-           A local declaration D  will be lifted to the same level as the 'ds', if D is in the -           where clause of one of ds's element declaration.-           A declaration D, say, in the expression 'e' will be lifted to 'ds' if D is not local to-           other declaration list in 'e'--        new: HsLet (HsLocalBinds id) (LHsExpr id)---    case5: In the case Alternative expression:(HsAlt loc p rhs ds)-           A local declaration D  will be lifted to the same level as the 'ds', if D is in the -           where clause of one of ds's element declaration.-           A declaration D in 'rhs' will be lifted to 'ds' if D is not local to other declaration -           list in 'rhs'.--        new: HsCase (LHsExpr id) (MatchGroup id)-           new is same as in a FunBind.---    case6: In the do statement expression:(HsLetStmt ds stmts)-           A local declaration D  will be lifted to the same level as the 'ds', if D is in the -           where clause of one of ds's element declaration.-           A declaration D in 'stmts' will be lifted to 'ds' if D is not local to other declaration -           list in 'stmts'.--        new: LetStmt (HsLocalBindsLR idL idR)-             in context GRHS [LStmt id] (LHsExpr id)---Function name: liftOneLevel-parameters: fileName--current file name.-            mod -- the scoped abstract syntax tree of the module.-            pn  -- the function/pattern name to be lifted.---}--liftOneLevel' :: GHC.ModuleName-                -> GHC.Located GHC.Name-                -> RefactGhc [ApplyRefacResult]--liftOneLevel' modName pn@(GHC.L _ n) = do-  renamed <- getRefactRenamed-  if isLocalFunOrPatName n renamed-        then do -- (mod', ((toks',m),_))<-liftOneLevel''-                (refactoredMod,_) <- applyRefac (liftOneLevel'') RSAlreadyLoaded-                let (b, pns) = liftedToTopLevel pn renamed-                if b &&  modIsExported modName renamed-                  then do clients<-clientModsAndFiles modName-                          -- logm $ "liftOneLevel':(clients,declPns)=" ++ (showGhc (clients,declPns))-                          refactoredClients <- mapM (liftingInClientMod modName pns) clients-                          return (refactoredMod:(concat refactoredClients))-                  else do return [refactoredMod]-        else error "\nThe identifer is not a function/pattern name!"--   where-      liftOneLevel''= do-             logm $ "in liftOneLevel''"-             renamed <- getRefactRenamed-             ztransformStagedM SYB.Renamer (Nothing-                                `SYB.mkQ` liftToModQ-                                `SYB.extQ` liftToMatchQ'-                                `SYB.extQ` liftToLet'-                                -- `SYB.mkQ` liftToMatchQ-                                -- `SYB.extQ` liftToLet-                                    ) (Z.toZipper renamed)--           where-             isValBinds :: GHC.HsValBinds GHC.Name -> Bool-             isValBinds _ = True--             isGRHSs :: GHC.GRHSs GHC.Name -> Bool-             isGRHSs _ = True--             isHsLet :: GHC.HsExpr GHC.Name -> Bool-             isHsLet (GHC.HsLet _ _) = True-             isHsLet _               = False--             liftToModQ ((g,_imps,_exps,_docs):: GHC.RenamedSource)-                | nonEmptyList candidateBinds-                  = Just (doLiftZ candidateBinds)-                | otherwise = Nothing-                where-                 candidateBinds = map snd-                                $ filter (\(l,_bs) -> nonEmptyList l)-                                $ map (\bs -> (definingDeclsNames [n] (hsBinds bs) False False,bs))-                                $ (hsBinds g)--             liftToMatchQ' :: (SYB.Data a) => GHC.Match GHC.Name -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a))-             liftToMatchQ' ((GHC.Match _pats _mtyp (GHC.GRHSs rhs ds))::GHC.Match GHC.Name)-                 | (nonEmptyList (definingDeclsNames [n] (hsBinds  ds) False False))-                    = Just (doLiftZ ds)-                 | (nonEmptyList (definingDeclsNames [n] (hsBinds rhs) False False))-                    = Just (doLiftZ rhs)-                 | otherwise = Nothing--             liftToLet' :: GHC.HsExpr GHC.Name -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a))-             liftToLet' ((GHC.HsLet ds _e)::GHC.HsExpr GHC.Name)-               | nonEmptyList (definingDeclsNames [n] (hsBinds ds) False  False)-                 = Just (doLiftZ ds)-               | otherwise = Nothing-             liftToLet' _ = Nothing--             doLiftZ :: (HsValBinds t)-               => t -> SYB.Stage -> Z.Zipper a-               -> RefactGhc (Z.Zipper a)-             doLiftZ ds _stage z =-                  do-                    logm $ "in liftOneLevel''.liftToLet in ds"--                    let zu = case (Z.up z) of-                              Just zz -> fromMaybe (error "MoveDef.liftToLet.1")-                                  $ upUntil (False `SYB.mkQ` isGRHSs-                                                   `SYB.extQ` isHsLet-                                                   `SYB.extQ` isValBinds)-                                     zz-                              Nothing -> z--                    let-                      wtop (ren::GHC.RenamedSource) = do-                        worker ren (hsBinds ds) pn True--                      wgrhs (grhss::GHC.GRHSs GHC.Name) = do-                         (_,dd) <- (hsFreeAndDeclaredPNs grhss)-                         worker1 grhss (hsBinds ds) pn dd False--                      wlet :: GHC.HsExpr GHC.Name -> RefactGhc (GHC.HsExpr GHC.Name)-                      wlet l@(GHC.HsLet dsl _e) = do-                        (_,dd) <- hsFreeAndDeclaredPNs dsl-                        dsl' <- worker1 l (hsBinds ds) pn dd False-                        return dsl'-                      wlet x = return x--                      wvalbinds (vb::GHC.HsValBinds GHC.Name) = do-                         (_,dd) <- (hsFreeAndDeclaredPNs vb)-                         worker1 vb (hsBinds ds) pn dd False--                    ds' <- Z.transM (SYB.mkM wtop `SYB.extM` wgrhs-                                     `SYB.extM` wlet `SYB.extM` wvalbinds) zu--                    return ds'--             -- TODO: merge worker and worker1-             worker :: (HsValBinds t,GHC.Outputable t)-                => t -- ^The destination of the lift operation-                -> [GHC.LHsBind GHC.Name] -- ^ list containing the-                                -- decl to be lifted-                -> GHC.Located GHC.Name -- ^ The name of the decl to-                                -- be lifted-                -> Bool -- ^True if lifting to the top level-                -> RefactGhc t-             worker dest ds pnn toToplevel-                  =do let (before,parent,after)=divideDecls ds pnn -- parent is misnomer, it is the decl to be moved-                          liftedDecls=definingDeclsNames [n] parent True  True-                          declaredPns=nub $ concatMap definedPNs liftedDecls-                      (_, dd) <- hsFreeAndDeclaredPNs dest-                      pns<-pnsNeedRenaming dest parent liftedDecls declaredPns-                      logm $ "MoveDef.worker: pns=" ++ (showGhc pns)-                      if pns==[]-                        then do-                                (parent',liftedDecls',_mLiftedSigs')<-addParamsToParentAndLiftedDecl n dd-                                                                     parent liftedDecls Nothing-                                --True means the new decl will be at the same level with its parant. -                                dest' <- moveDecl1 (replaceBinds dest (before++parent'++after))-                                           (Just (ghead "worker" (definedPNs (ghead "worker" parent'))))-                                           [n] (Just liftedDecls') declaredPns toToplevel -- False -- ++AZ++ TODO: should be True for toplevel move-                                return dest'-                                --parent'<-doMoving declaredPns (ghead "worker" parent) True  paramAdded parent'-                                --return (before++parent'++liftedDecls''++after)-                        else askRenamingMsg pns "lifting"--             worker1 :: (HsValBinds t,GHC.Outputable t)-                => t -- ^The destination of the lift operation-                -> [GHC.LHsBind GHC.Name] -- ^ list containing the-                                -- decl to be lifted-                -> GHC.Located GHC.Name -- ^ The name of the decl to-                                -- be lifted-                -> [GHC.Name] -- ^Declared variables in the destination-                -> Bool -- ^True if lifting to the top level-                -> RefactGhc t-             worker1 dest ds pnn dd toToplevel-                  {--                  Actions required-                    1. add parameters to original decls if required-                    2. add parameters to any points that call the lifted decl-                       once it is lifted-                    3. Replace the above in the AST-                    4. Do the move-                  -}--                  =do let (_before,decl,_after)=divideDecls ds pnn-                          liftedDecls=definingDeclsNames [n] decl True  True-                          declaredPns=nub $ concatMap definedPNs liftedDecls--                      pns <- pnsNeedRenaming dest decl liftedDecls declaredPns-                      logm $ "MoveDef.worker1: pns=" ++ (showGhc pns)-                      if pns==[]-                        then do-                                (parent',liftedDecls',_mLiftedSigs')-                                    <- addParamsToParentAndLiftedDecl n dd dest liftedDecls Nothing-                                --True means the new decl will be at the same level with its parant. -                                parent'' <- moveDecl1 parent' Nothing-                                             [n] (Just liftedDecls') declaredPns toToplevel -- False -- ++AZ++ TODO: should be True for toplevel move-                                return parent''-                                --decl'<-doMoving declaredPns (ghead "worker" decl) True  paramAdded decl'-                                --return (before++decl'++liftedDecls''++after)-                        else askRenamingMsg pns "lifting"---liftedToTopLevel :: GHC.Located GHC.Name -> GHC.RenamedSource -> (Bool,[GHC.Name])-liftedToTopLevel pnt@(GHC.L _ pn) renamed-  = if nonEmptyList (definingDeclsNames [pn] (hsBinds renamed) False True)-     then let (_, parent,_) = divideDecls (hsBinds renamed) pnt-              liftedDecls=definingDeclsNames [pn] (hsBinds parent) True True-              declaredPns  = nub $ concatMap definedPNs liftedDecls-          in (True, declaredPns)-     else (False, [])---addParamsToParentAndLiftedDecl :: (HsValBinds t,GHC.Outputable t) =>-     GHC.Name   -- ^name of decl being lifted-  -> [GHC.Name] -- ^Declared names in parent-  -> t          -- ^parent-  -> [GHC.LHsBind GHC.Name] -- ^decls being lifted-  -> Maybe (GHC.LSig GHC.Name) -- ^ lifted decls signature if present-  -> RefactGhc (t, [GHC.LHsBind GHC.Name], Maybe (GHC.LSig GHC.Name))-addParamsToParentAndLiftedDecl pn dd parent liftedDecls mLiftedSigs-  =do  (ef,_) <- hsFreeAndDeclaredPNs parent-       (lf,_) <- hsFreeAndDeclaredPNs liftedDecls--       -- logm $ "addParamsToParentAndLiftedDecl:parent=" ++ (showGhc parent)--       -- parameters to be added to pn because of lifting-       let newParams= ((nub lf) \\ (nub ef)) \\ dd--       logm $ "addParamsToParentAndLiftedDecl:(newParams,ef,lf,dd)=" ++ (showGhc (newParams,ef,lf,dd))--       if newParams /= []-         then if  (any isComplexPatBind liftedDecls)-                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--                        parent' <- addParamsToParent pn newParams parent''--                        liftedDecls' <- addParamsToDecls [liftedDecls''] pn newParams True--                        mLiftedSigs' <- addParamsToSigs newParams mLiftedSigs--                        logm $ "addParamsToParentAndLiftedDecl:mLiftedSigs'=" ++ showGhc mLiftedSigs'--                        return (parent',liftedDecls', mLiftedSigs')-         else return (parent,liftedDecls,mLiftedSigs)---- ------------------------------------------------------------------------- TODO: perhaps move this to TypeUtils-addParamsToSigs :: [GHC.Name] -> Maybe (GHC.LSig GHC.Name) -> RefactGhc (Maybe (GHC.LSig GHC.Name))-addParamsToSigs _ Nothing = return Nothing-addParamsToSigs [] ms = return ms-addParamsToSigs newParams (Just (GHC.L l (GHC.TypeSig lns ltyp@(GHC.L lt _)))) = do-  mts <- mapM getTypeForName newParams-  let ts = catMaybes mts-  -- Note : the '::' symbol lies between the lns and the ltyp. Hence-  --        construct a new location covering this gap, to insert the mew-  --        params. This span has been specifically inserted into the-  --        TokenTree when it is initially loaded.-  let ne = GHC.srcSpanEnd $ GHC.getLoc  $ glast "addParamsToSigs" lns-      ls = GHC.srcSpanStart $ lt-      replaceSpan = GHC.mkSrcSpan ne ls-      newStr = ":: " ++ (intercalate " -> " $ map printSigComponent ts) ++ " -> "-  logm $ "addParamsToSigs:replaceSpan=" ++ showGhc replaceSpan-  logm $ "addParamsToSigs:newStr=[" ++ newStr ++ "]"-  let newToks = basicTokenise newStr-  void $ putToksForSpan replaceSpan newToks-  let typ' = foldl addOneType ltyp ts-  sigOk <- isNewSignatureOk ts-  logm $ "addParamsToSigs:(sigOk,newStr)=" ++ show (sigOk,newStr)-  if sigOk-    then return $ Just (GHC.L l (GHC.TypeSig lns typ'))-    else error $ "\nNew type signature may fail type checking: " ++ newStr ++ "\n"-  where-    addOneType :: GHC.LHsType GHC.Name -> GHC.Type -> GHC.LHsType GHC.Name-    addOneType et t = GHC.noLoc (GHC.HsFunTy (GHC.noLoc hst) et)-      where-        hst = typeToHsType t--addParamsToSigs np ls = error $ "addParamsToSigs: no match for:" ++ showGhc (np,ls)---- -----------------------------------------------------------------------printSigComponent :: GHC.Type -> String-printSigComponent x = ppType x---- ------------------------------------------------------------------------- |Fail any signature having a forall in it.--- TODO: this is unnecesarily restrictive, but needs--- a) proper reversing of GHC.Type to GHC.LhsType--- b) some serious reverse type inference to ensure that the---    constraints are modified properly to merge the old signature---    part and the new.-isNewSignatureOk :: [GHC.Type] -> RefactGhc Bool-isNewSignatureOk types = do-  -- NOTE: under some circumstances enabling Rank2Types or RankNTypes-  --       can resolve the type conflict, this can potentially be checked-  --       for.-  -- NOTE2: perhaps proceed and reload the tentative refactoring into-  --        the GHC session and accept it only if it type checks-  let-    r = SYB.everythingStaged SYB.TypeChecker (++) []-          ([] `SYB.mkQ` usesForAll) types-    usesForAll (GHC.ForAllTy _ _) = [1::Int]-    usesForAll _                  = []--  -- logm $ "isNewSignatureOk:r=" ++ show r-  return $ emptyList r---- ------------------------------------------------------------------------- TODO: perhaps move this to TypeUtils--- TODO: complete this-typeToHsType :: GHC.Type -> GHC.HsType GHC.Name-typeToHsType (GHC.TyVarTy v) = GHC.HsTyVar (Var.varName v)-typeToHsType (GHC.AppTy t1 t2) = GHC.HsAppTy (GHC.noLoc $ typeToHsType t1)-                                             (GHC.noLoc $ typeToHsType t2)--typeToHsType t@(GHC.TyConApp _tc _ts) = tyConAppToHsType t--typeToHsType (GHC.FunTy t1 t2) = GHC.HsFunTy (GHC.noLoc $ typeToHsType t1)-                                             (GHC.noLoc $ typeToHsType t2)-#if __GLASGOW_HASKELL__ > 704-typeToHsType (GHC.ForAllTy _v t) = GHC.HsForAllTy GHC.Explicit (GHC.HsQTvs [] []) (GHC.noLoc []) (GHC.noLoc $ typeToHsType t)-#else-typeToHsType (GHC.ForAllTy _v t) = GHC.HsForAllTy GHC.Explicit [] (GHC.noLoc []) (GHC.noLoc $ typeToHsType t)-#endif--#if __GLASGOW_HASKELL__ > 704-typeToHsType (GHC.LitTy (GHC.NumTyLit i)) = GHC.HsTyLit (GHC.HsNumTy i)-typeToHsType (GHC.LitTy (GHC.StrTyLit s)) = GHC.HsTyLit (GHC.HsStrTy s)-#endif--{--data Type-  = TyVarTy Var	-- ^ Vanilla type or kind variable (*never* a coercion variable)--  | AppTy         -- See Note [AppTy invariant]-	Type-	Type		-- ^ Type application to something other than a 'TyCon'. Parameters:-	                ---                        --  1) Function: must /not/ be a 'TyConApp',-                        --     must be another 'AppTy', or 'TyVarTy'-	                ---	                --  2) Argument type--  | TyConApp      -- See Note [AppTy invariant]-	TyCon-	[KindOrType]	-- ^ Application of a 'TyCon', including newtypes /and/ synonyms.-	                -- Invariant: saturated appliations of 'FunTyCon' must-	                -- use 'FunTy' and saturated synonyms must use their own-                        -- constructors. However, /unsaturated/ 'FunTyCon's-                        -- do appear as 'TyConApp's.-	                -- Parameters:-	                ---	                -- 1) Type constructor being applied to.-	                ---                        -- 2) Type arguments. Might not have enough type arguments-                        --    here to saturate the constructor.-                        --    Even type synonyms are not necessarily saturated;-                        --    for example unsaturated type synonyms-	                --    can appear as the right hand side of a type synonym.--  | FunTy-	Type-	Type		-- ^ Special case of 'TyConApp': @TyConApp FunTyCon [t1, t2]@-			-- See Note [Equality-constrained types]--  | ForAllTy-	Var         -- Type or kind variable-	Type	        -- ^ A polymorphic type--  | LitTy TyLit     -- ^ Type literals are simillar to type constructors.---}--tyConAppToHsType :: GHC.Type -> GHC.HsType GHC.Name-tyConAppToHsType (GHC.TyConApp tc _ts)-  | GHC.isFunTyCon tc = r "isFunTyCon"-  | GHC.isAlgTyCon tc = r "isAlgTyCon"-  | GHC.isTupleTyCon tc = r "isTupleTyCon"-  | GHC.isSynTyCon tc = r "isSynTyCon"-  | GHC.isPrimTyCon tc = r "isPrimTyCon"-#if __GLASGOW_HASKELL__ > 704-  | GHC.isPromotedDataCon tc = r "isPromotedDataTyCon"-  | GHC.isPromotedTyCon tc =  r "isPromotedTyCon"-#endif-  where--#if __GLASGOW_HASKELL__ > 704-    r str = GHC.HsTyLit (GHC.HsStrTy $ GHC.mkFastString str)-#else-    r str = error $ "tyConAppToHsType: " ++ str ++ " unexpected:" ++ (SYB.showData SYB.TypeChecker 0 r)-#endif--tyConAppToHsType t@(GHC.TyConApp _tc _ts)-   = error $ "tyConAppToHsType: unexpected:" ++ (SYB.showData SYB.TypeChecker 0 t)--{--HsType-HsForAllTy HsExplicitFlag (LHsTyVarBndrs name) (LHsContext name) (LHsType name)-HsTyVar name-HsAppTy (LHsType name) (LHsType name)-HsFunTy (LHsType name) (LHsType name)-HsListTy (LHsType name)-HsPArrTy (LHsType name)-HsTupleTy HsTupleSort [LHsType name]-HsOpTy (LHsType name) (LHsTyOp name) (LHsType name)-HsParTy (LHsType name)-HsIParamTy HsIPName (LHsType name)-HsEqTy (LHsType name) (LHsType name)-HsKindSig (LHsType name) (LHsKind name)-HsQuasiQuoteTy (HsQuasiQuote name)-HsSpliceTy (HsSplice name) FreeVars PostTcKind-HsDocTy (LHsType name) LHsDocString-HsBangTy HsBang (LHsType name)-HsRecTy [ConDeclField name]-HsCoreTy Type-HsExplicitListTy PostTcKind [LHsType name]-HsExplicitTupleTy [PostTcKind] [LHsType name]-HsTyLit HsTyLit-HsWrapTy HsTyWrapper (HsType name)--}-----{--  = -- | The function type constructor, @(->)@-    FunTyCon {-        tyConUnique :: Unique,-        tyConName   :: Name,-        tc_kind   :: Kind,-        tyConArity  :: Arity-    }--  -- | Algebraic type constructors, which are defined to be those-  -- arising @data@ type and @newtype@ declarations.  All these-  -- constructors are lifted and boxed. See 'AlgTyConRhs' for more-  -- information.-  | AlgTyCon {-        tyConUnique :: Unique,-        tyConName   :: Name,-        tc_kind     :: Kind,-        tyConArity  :: Arity,--        tyConTyVars :: [TyVar],   -- ^ The kind and type variables used in the type constructor.-                                  -- Invariant: length tyvars = arity-                                  -- Precisely, this list scopes over:-                                  ---                                  -- 1. The 'algTcStupidTheta'-                                  -- 2. The cached types in 'algTyConRhs.NewTyCon'-                                  -- 3. The family instance types if present-                                  ---                                  -- Note that it does /not/ scope over the data constructors.-        tyConCType   :: Maybe CType, -- The C type that should be used-                                     -- for this type when using the FFI-                                     -- and CAPI--        algTcGadtSyntax  :: Bool,       -- ^ Was the data type declared with GADT syntax?-                                        -- If so, that doesn't mean it's a true GADT;-                                        -- only that the "where" form was used.-                                        -- This field is used only to guide pretty-printing--        algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data type-                                        -- (always empty for GADTs).-                                        -- A \"stupid theta\" is the context to the left-                                        -- of an algebraic type declaration,-                                        -- e.g. @Eq a@ in the declaration-                                        --    @data Eq a => T a ...@.--        algTcRhs :: AlgTyConRhs,  -- ^ Contains information about the-                                  -- data constructors of the algebraic type--        algTcRec :: RecFlag,      -- ^ Tells us whether the data type is part-                                  -- of a mutually-recursive group or not--        algTcParent :: TyConParent      -- ^ Gives the class or family declaration 'TyCon'-                                        -- for derived 'TyCon's representing class-                                        -- or family instances, respectively.-                                        -- See also 'synTcParent'-    }--  -- | Represents the infinite family of tuple type constructors,-  --   @()@, @(a,b)@, @(# a, b #)@ etc.-  | TupleTyCon {-        tyConUnique    :: Unique,-        tyConName      :: Name,-        tc_kind        :: Kind,-        tyConArity     :: Arity,-        tyConTupleSort :: TupleSort,-        tyConTyVars    :: [TyVar],-        dataCon        :: DataCon -- ^ Corresponding tuple data constructor-    }--  -- | Represents type synonyms-  | SynTyCon {-        tyConUnique  :: Unique,-        tyConName    :: Name,-        tc_kind    :: Kind,-        tyConArity   :: Arity,--        tyConTyVars  :: [TyVar],        -- Bound tyvars--        synTcRhs     :: SynTyConRhs,    -- ^ Contains information about the-                                        -- expansion of the synonym--        synTcParent  :: TyConParent     -- ^ Gives the family declaration 'TyCon'-                                        -- of 'TyCon's representing family instances--    }--  -- | Primitive types; cannot be defined in Haskell. This includes-  -- the usual suspects (such as @Int#@) as well as foreign-imported-  -- types and kinds-  | PrimTyCon {-        tyConUnique   :: Unique,-        tyConName     :: Name,-        tc_kind       :: Kind,-        tyConArity    :: Arity,         -- SLPJ Oct06: I'm not sure what the significance-                                        --             of the arity of a primtycon is!--        primTyConRep  :: PrimRep,       -- ^ Many primitive tycons are unboxed, but some are-                                        --   boxed (represented by pointers). This 'PrimRep'-                                        --   holds that information.-                                        -- Only relevant if tc_kind = *--        isUnLifted   :: Bool,           -- ^ Most primitive tycons are unlifted-                                        --   (may not contain bottom)-                                        --   but foreign-imported ones may be lifted--        tyConExtName :: Maybe FastString   -- ^ @Just e@ for foreign-imported types,-                                           --   holds the name of the imported thing-    }--  -- | Represents promoted data constructor.-  | PromotedDataCon {         -- See Note [Promoted data constructors]-        tyConUnique :: Unique, -- ^ Same Unique as the data constructor-        tyConName   :: Name,   -- ^ Same Name as the data constructor-        tyConArity  :: Arity,-        tc_kind     :: Kind,   -- ^ Translated type of the data constructor-        dataCon     :: DataCon -- ^ Corresponding data constructor-    }--  -- | Represents promoted type constructor.-  | PromotedTyCon {-        tyConUnique :: Unique, -- ^ Same Unique as the type constructor-        tyConName   :: Name,   -- ^ Same Name as the type constructor-        tyConArity  :: Arity,  -- ^ n if ty_con :: * -> ... -> *  n times-        tc_kind     :: Kind,   -- ^ Always TysPrim.superKind-        ty_con      :: TyCon   -- ^ Corresponding type constructor-    }--  deriving Typeable---}----------------------------------End of Lifting-------------------------------------------{-Refactoring : demote a function/pattern binding(simpe or complex) to the declaration where it is used.-  Descritption: if a declaration D, say, is only used by another declaration F,say, then D can be -                demoted into the local declaration list (where clause) in F.-                So currently, D can not be demoted if more than one declaration use it. --                In a multi-module context, a top-level definition can not be demoted if it is used-                by other modules. In the case that the demoted identifer is in the hiding list of-                import declaration in a client module, it should be removed from the hiding list.-- Function name:demote- parameters: fileName--current file name.-             mod -- the scoped abstract syntax tree of the module.-             pn  -- the function/pattern name to be demoted.---}--demote' ::-     GHC.ModuleName-  -- -> FilePath-  -- -> (ParseResult,[PosToken])-  -> GHC.Located GHC.Name-  -> RefactGhc [ApplyRefacResult]-demote' modName (GHC.L _ pn) = do-  renamed <- getRefactRenamed-  if isFunOrPatName pn renamed-    then do-       isTl <- isTopLevelPN pn-       if isTl && isExplicitlyExported pn renamed-          then error "This definition can not be demoted, as it is explicitly exported by the current module!"-          else do -- (mod',((toks',m),_))<-doDemoting pn fileName mod toks-                  (refactoredMod,_) <- applyRefac (doDemoting pn) RSAlreadyLoaded-                  -- isTl <- isTopLevelPN pn-                  if isTl && modIsExported modName renamed-                    then do let demotedDecls'= definingDeclsNames [pn] (hsBinds renamed) True False-                                declaredPns  = nub $ concatMap definedPNs demotedDecls'-                            clients <- clientModsAndFiles modName-                            logm $ "demote':clients=" ++ (showGhc clients)-                            refactoredClients <-mapM (demotingInClientMod declaredPns) clients-                            -- return (refactoredMod:[])-                            return (refactoredMod:refactoredClients)-                    else do return [refactoredMod]-    else error "\nInvalid cursor position!"----- |Do refactoring in the client module, that is:---  a) Check whether the identifier is used in the module body---  b) If the identifier is not used but is hided by the import---     declaration, then remove it from the hiding.-demotingInClientMod ::-  [GHC.Name] -> TargetModule-  -> RefactGhc ApplyRefacResult-demotingInClientMod pns targetModule@(_,modSummary) = do-  void $ activateModule targetModule-  (refactoredMod,_) <- applyRefac (doDemotingInClientMod pns (GHC.ms_mod modSummary)) RSAlreadyLoaded-  return refactoredMod---doDemotingInClientMod :: [GHC.Name] -> GHC.Module -> RefactGhc ()-doDemotingInClientMod pns modName = do-  renamed@(_g,imps,exps,_docs) <- getRefactRenamed-  if any (\pn->findPN pn (hsBinds renamed) || findPN pn (exps)) pns-     then error $ "This definition can not be demoted, as it is used in the client module '"++(showGhc modName)++"'!"-     else if any (\pn->findPN pn imps) pns-             -- TODO: reinstate this-             then do -- (mod',((ts',m),_))<-runStateT (rmItemsFromImport mod pns) ((ts,unmodified),(-1000,0))-                     return ()-             else return ()--doDemoting :: GHC.Name -> RefactGhc ()-doDemoting  pn = do--  clearRefactDone -- Only do this action once--  renamed  <- getRefactRenamed-  -- logm $ "MoveDef.doDemoting:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++--  -- everywhereMStaged' is top-down, does all-  renamed' <- everywhereMStaged' SYB.Renamer (SYB.mkM   demoteInMod-                                             `SYB.extM` demoteInMatch-                                             `SYB.extM` demoteInPat-                                             `SYB.extM` demoteInLet-                                             `SYB.extM` demoteInStmt-                                            ) renamed-  -- error ("doDemoting:renamed'=" ++ (showGhc renamed'))-  putRefactRenamed renamed'-  -- ren <- getRefactRenamed-  -- error ("doDemoting:ren=" ++ (showGhc ren))-  showLinesDebug "doDemoting done"-  return ()-    where-       --1. demote from top level-       -- demoteInMod (mod@(HsModule loc name exps imps ds):: HsModuleP)-       demoteInMod (renamed :: GHC.RenamedSource)-         | not $ emptyList decls-         = do-              logm "MoveDef:demoteInMod" -- ++AZ++-              demoted <- doDemoting' renamed pn-              return demoted-         where-           decls = (definingDeclsNames [pn] (hsBinds renamed) False False)-       demoteInMod x = return x--       --2. The demoted definition is a local decl in a match-       -- demoteInMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)-       demoteInMatch (match@(GHC.Match _pats _mt (GHC.GRHSs _ ds))::GHC.Match GHC.Name)-         -- was | definingDecls [pn] ds False False/=[]-         | not $ emptyList (definingDeclsNames [pn] (hsBinds ds) False False)-         = do-              logm "MoveDef:demoteInMatch" -- ++AZ++-              done <- getRefactDone-              match' <- if (not done)-                then doDemoting' match pn-                else return match-              return match'-       demoteInMatch  x = return x--       --3. The demoted definition is a local decl in a pattern binding-       -- demoteInPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)-       demoteInPat (pat@((GHC.PatBind _p rhs _ _ _))::GHC.HsBind GHC.Name)-         -- was | definingDecls [pn] ds False False /=[]-         | not $ emptyList (definingDeclsNames [pn] (hsBinds rhs) False False)-          = do-              logm "MoveDef:demoteInPat" -- ++AZ++-              done <- getRefactDone-              pat' <- if (not done)-                then doDemoting' pat pn-                else return pat-              return pat'-       demoteInPat x = return x--       --4: The demoted definition is a local decl in a Let expression-       -- demoteInLet (letExp@(Exp (HsLet ds e))::HsExpP)-       demoteInLet (letExp@(GHC.L _ (GHC.HsLet ds _e))::GHC.LHsExpr GHC.Name)-         -- was | definingDecls [pn] ds False False/=[]-         | not $ emptyList (definingDeclsNames [pn] (hsBinds ds) False False)-          = do-              logm "MoveDef:demoteInLet" -- ++AZ++-              done <- getRefactDone-              letExp' <- if (not done)-                 then doDemoting' letExp pn-                 else return letExp-              return letExp'-       demoteInLet x = return x--       -- TODO: the rest of these cases below-{--       --5. The demoted definition is a local decl in a case alternative.-       demoteInAlt (alt@(HsAlt loc p rhs ds)::(HsAlt (HsExpP) (HsPatP) [HsDeclP]))-         | definingDecls [pn] ds False False /=[]-          = doDemoting'  alt pn-       demoteInAlt _=mzero--}--       --6.The demoted definition is a local decl in a Let statement.-       -- demoteInStmt (letStmt@(HsLetStmt ds stmts):: (HsStmt (HsExpP) (HsPatP) [HsDeclP]))-       demoteInStmt (letStmt@(GHC.LetStmt binds)::GHC.Stmt GHC.Name)-         -- was | definingDecls [pn] ds False False /=[]-         | not $ emptyList (definingDeclsNames [pn] (hsBinds binds) False False)-          = do-              logm "MoveDef:demoteInStmt" -- ++AZ++-              done <- getRefactDone-              letStmt' <- if (not done)-                then doDemoting' letStmt pn-                else return letStmt-              return letStmt'-       demoteInStmt x =return x--       -- TODO: the rest of these cases below-{--       failure=idTP `adhocTP` mod-             where-               mod (m::HsModuleP)-                = error "Refactoring failed!"   --SHOULD GIVE MORE DETAILED ERROR MESSAGE--}------ |Demote the declaration of 'pn' in the context of 't'.-doDemoting' :: (HsValBinds t, UsedByRhs t) => t -> GHC.Name -> RefactGhc t-doDemoting' t pn = do-   let origDecls = hsBinds t-       demotedDecls'= definingDeclsNames [pn] origDecls True False-       declaredPns = nub $ concatMap definedPNs demotedDecls'-       pnsUsed = usedByRhs t declaredPns-   logm $ "doDemoting':(pn,declaredPns)=" ++ showGhc (pn,declaredPns)-   -- logm $ "doDemoting':t=" ++ (SYB.showData SYB.Renamer 0 t)-   logm $ "doDemoting':(declaredPns,pnsUsed)=" ++ showGhc (declaredPns,pnsUsed)-   r <-  if not pnsUsed -- (usedByRhs t declaredPns)-       then do-              -- drawTokenTree "" -- ++AZ++ debug-              let demotedDecls = definingDeclsNames [pn] (hsBinds t) True True-              let-                  otherBinds = (deleteFirstsBy sameBind (hsBinds t) demotedDecls)-                  -- uselist = uses declaredPns otherBinds-                      {- From 'hsDecls t' to 'hsDecls t \\ demotedDecls'.-                         Bug fixed 06/09/2004 to handle direct recursive function.-                       -}-                  -- uselist = concatMap (\r -> if (emptyList r) then [] else ["Used"]) $ map (\b -> uses declaredPns [b]) otherBinds-                  xx = map (\b -> (b,uses declaredPns [b])) otherBinds-                  useCount = sum $ concatMap snd xx-              -- logm $ "doDemoting': uses xx=" ++ (showGhc xx)-              -- logm $ "doDemoting': uses useCount=" ++ (show useCount)--              case useCount  of-                  0 ->do error "\n Nowhere to demote this function!\n"-                  1 -> --This function is only used by one friend function-                      do-                         logm "MoveDef.doDemoting':target location found" -- ++AZ++--                         (f,_d) <- hsFreeAndDeclaredPNs demotedDecls-                         (ds,removedDecl,_sigRemoved) <- rmDecl pn False t--                         (t',demotedSigs) <- rmTypeSigs declaredPns ds--                         let (GHC.L ssd _) = removedDecl-                         demotedToks <- getToksForSpan ssd--                         -- TODO: move this to its own fn-                         let getToksForMaybeSig (GHC.L ss _) = do-                                                   sigToks <- getToksForSpan ss-                                                   return sigToks--                         demotedSigToksLists <- mapM getToksForMaybeSig demotedSigs-                         let demotedSigToks = concat demotedSigToksLists-                         -- end TODO--                         logm $ "MoveDef:declaredPns=" ++ (showGhc declaredPns) -- ++AZ++--                         --get those variables declared at where the demotedDecls will be demoted to-                         -- let dl = map (flip declaredNamesInTargetPlace ds) declaredPns-                         dl <- mapM (flip declaredNamesInTargetPlace ds) declaredPns-                         logm $ "mapM declaredNamesInTargetPlace done"-                         --make sure free variable in 'f' do not clash with variables in 'dl',-                         --otherwise do renaming.-                         let clashedNames=filter (\x-> elem (id x) (map id f)) $ (nub.concat) dl-                         --rename clashed names to new names created automatically,update TOKEN STREAM as well.-                         if clashedNames/=[]-                            then error ("The identifier(s):" ++ showGhc clashedNames ++-                                       ", declared in where the definition will be demoted to, will cause name clash/capture"-                                       ++" after demoting, please do renaming first!")-                                 --ds'<-foldM (flip (autoRenameLocalVar True)) ds clashedNames-                            else  --duplicate demoted declarations to the right place.-                                 do-                                    logm $ "MoveDef: about to duplicateDecls"-                                    ds'' <- duplicateDecls declaredPns removedDecl demotedSigs (Just (demotedSigToks ++ demotedToks)) (hsBinds ds)-                                    logm $ "MoveDef:duplicateDecls done"--                                    return (replaceBinds t' ds'')-                  _ ->error "\nThis function/pattern binding is used by more than one friend bindings\n"--       else error "This function can not be demoted as it is used in current level!\n"--   return r--    where-          ---find how many matches/pattern bindings use  'pn'--------          -- uses :: [GHC.Name] -> [GHC.LHsBind GHC.Name] -> [Int]-          uses pns t2-               = concatMap used t2-                where--                  used :: GHC.LHsBind GHC.Name -> [Int]-                  used (GHC.L _ (GHC.FunBind _n _ (GHC.MatchGroup matches _) _ _ _))-                     = concatMap (usedInMatch pns) matches--                  used (GHC.L _ (GHC.PatBind pat rhs _ _ _))-                    -- was | hsPNs p `intersect` pns ==[]  && any  (flip findPN pat) pns-                    | (not $ findPNs pns pat) && findPNs pns rhs-                    = [1::Int]-                  used  _ = []--          usedInMatch pns (GHC.L _ (GHC.Match pats _ rhs))-            -- was | isNothing (find (==pname) pns) && any  (flip findPN match) pns-            | (not $ findPNs pns pats) && findPNs pns rhs-             = [1::Int]-          usedInMatch _ _ = []---          -- duplicate demotedDecls to the right place (the outer most level where it is used).-          duplicateDecls :: [GHC.Name] -- ^ function names to be demoted-                         -> GHC.LHsBind GHC.Name -- ^Bind being demoted-                         -> [GHC.LSig GHC.Name] -- ^Signatures being demoted, if any-                         -> Maybe [PosToken]          -- ^Tokens if provided-                         -> [GHC.LHsBind GHC.Name]    -- ^Binds of original top level entiity, including src and dst-                         -> RefactGhc [GHC.LHsBind GHC.Name]-          duplicateDecls pns demoted dsig dtoks decls-             -- = do everywhereMStaged SYB.Renamer (SYB.mkM dupInMatch-             = do-                  -- logm "duplicateDecls:clearing done"  -- ++AZ++-                  -- clearRefactDone-                  everywhereMStaged' SYB.Renamer (SYB.mkM dupInMatch -- top-down approach-             -- = do somewhereMStaged SYB.Renamer (SYB.mkM dupInMatch -- need working MonadPlus for somewhereMStaged-                                                `SYB.extM` dupInPat) decls-             {--             = do applyTP (once_tdTP (failTP `adhocTP` dupInMatch-                                             `adhocTP` dupInPat)) decls-                  --error (show decls' ++ "\n" ++ prettyprint decls')-                  -- rmDecl (ghead "moveDecl3"  pns) False =<<foldM (flip rmTypeSig) decls' pns -             -}-               where-                 -- dupInMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)-                 dupInMatch (match@(GHC.Match pats _mt rhs) :: GHC.Match GHC.Name)-                   -- was | any (flip findPN match) pns && not (any (flip findPN name) pns)-                   | (not $ findPNs pns pats) && findPNs pns rhs-                   =  do-                        done <- getRefactDone-                        logm $ "duplicateDecls.dupInMatch:value of done=" ++ (show done) -- ++AZ++-                        if done-                          then return match-                          else do-                            logm "duplicateDecls:setting done"  -- ++AZ++-                            setRefactDone-                            --If not fold parameters.-                            -- moveDecl pns pats False decls False-                            {- ++AZ++ foldParams instead-                            rhs' <- addDecl rhs Nothing (demoted,dsig,dtoks) False-                            return (GHC.Match pats mt rhs')-                            -}-                            -- If fold parameters.-                            -- error "dupInMatch" -- ++AZ++-                            match' <- foldParams pns match decls demoted dsig dtoks-                            return match'-                 -- dupInMatch _ =mzero-                 dupInMatch x = return x--                 -- dupInPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)-                 dupInPat ((GHC.PatBind pat rhs ty fvs ticks) :: GHC.HsBind GHC.Name)-                    -- was |any (flip findPN pat) pns && not (any (flip findPN p) pns)-                    | (not $ findPNs pns pat) && findPNs pns rhs-                   -- =  moveDecl pns pat False decls False-                   = do-                       logm $ "duplicateDecls.dupInPat"-                       -- rhs' <- moveDecl pns rhs False decls False-                       -- TODO: what wbout dtoks?-                       -- error "dupInPat" -- ++AZ++-                       rhs' <- moveDecl1 rhs Nothing pns Nothing pns False-                       return (GHC.PatBind pat rhs' ty fvs ticks)-                 -- dupInPat _ =mzero-                 dupInPat x = return x--                 -- demotedDecls = definingDecls pns decls True False-          ----------------------------------------------------------------------          {--          declaredNamesInTargetPlace :: (Term t, MonadPlus m)=>PName->t->m [PName]-          declaredNamesInTargetPlace pn=applyTU (stop_tdTU (failTU-                                                    `adhocTU` inMatch-                                                    `adhocTU` inPat))-          -}-          declaredNamesInTargetPlace :: (SYB.Data t)-                            => GHC.Name -> t-                            -- -> RefactGhc [GHC.Name]-                            -> RefactGhc [GHC.Name]--          declaredNamesInTargetPlace pn' t' = do-             logm $ "declaredNamesInTargetPlace:pn=" ++ (showGhc pn')-             res <- applyTU (stop_tdTUGhc (failTU-                                           `adhocTU` inMatch-                                           `adhocTU` inPat)) t'-             logm $ "declaredNamesInTargetPlace:res=" ++ (showGhc res)-             return res-               where-                 -- inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)-                 inMatch ((GHC.Match _pats _ rhs) :: GHC.Match GHC.Name)-                    | findPN pn' rhs = do-                     logm $ "declaredNamesInTargetPlace:inMatch"-                     fds <- hsFDsFromInside rhs-                     return $ snd fds-                     -- (return.snd) =<< hsFDsFromInside rhs-                 -- inMatch _ = mzero-                 inMatch _ = return mzero--                 -- inPat (pat@(Dec (HsPatBind loc p rhs ds)):: HsDeclP)-                 inPat ((GHC.PatBind pat rhs _ _ _) :: GHC.HsBind GHC.Name)-                    |findPN pn' rhs = do-                     logm $ "declaredNamesInTargetPlace:inPat"-                     fds <- hsFDsFromInside pat-                     return $ snd fds-                     -- (return.snd) =<< hsFDsFromInside pat-                 -- inPat _=  mzero-                 inPat _=  return mzero------ --------------------------------------------------------------------------{- foldParams:remove parameters in the demotedDecls if possible-   parameters: pn -- the function/pattern name to be demoted in PName format-               match--where the demotedDecls will be demoted to-               demotedDecls -- the declarations to be demoted.-   example:-    module Test where        demote 'sq'       module Test where-    sumSquares x y               ===>          sumSquares x y =(sq 0) + (sq y)-      = sq x 0+ sq x y                               where sq y=x ^ y-    sq x y=x^y--}---PROBLEM: TYPE SIGNATURE SHOULD BE CHANGED.---- TEST THIS FUNCTION!!!-foldParams :: [GHC.Name]             -- ^The (list?) function name being demoted-           -> GHC.Match GHC.Name     -- ^The RHS of the place to receive the demoted decls-           -> [GHC.LHsBind GHC.Name] -- ^Binds of original top level entiity, including src and dst-           -> GHC.LHsBind GHC.Name   -- ^The decls being demoted-           -> [GHC.LSig GHC.Name]    -- ^Signatures being demoted, if any-           -> Maybe [PosToken]          -- ^Tokens if provided-           -> RefactGhc (GHC.Match GHC.Name)-foldParams pns ((GHC.Match pats mt rhs)::GHC.Match GHC.Name) _decls demotedDecls dsig dtoks--     =do-         logm $ "MoveDef.foldParams entered"-         -- logm $ "MoveDef.foldParams:match=" ++ (SYB.showData SYB.Renamer 0 match)--         let matches=concatMap matchesInDecls [GHC.unLoc demotedDecls]-             pn=ghead "foldParams" pns    --pns /=[]-         params <- allParams pn rhs []-         if (length.nub.map length) params==1                  -- have same number of param -             && ((length matches)==1)      -- only one 'match' in the demoted declaration-           then do-                   let patsInDemotedDecls=(patsInMatch.(ghead "foldParams")) matches-                       subst=mkSubst patsInDemotedDecls params-                       fstSubst=map fst subst-                       sndSubst=map snd subst--                   -- logm $ "MoveDef.foldParams before rmParamsInParent"-                   rhs' <- rmParamsInParent pn sndSubst rhs-                   -- logm $ "MoveDef.foldParams after rmParamsInParent"--                   -- ls<-mapM hsFreeAndDeclaredPNs sndSubst-                   -- ls <- mapM hsFreeAndDeclaredPNs sndSubst-                   ls <- mapM hsFreeAndDeclaredPNs sndSubst-                   -- newNames contains the newly introduced names to the demoted decls----                   -- let newNames=(map pNtoName (concatMap fst ls)) \\ (map pNtoName fstSubst)-                   let newNames=((concatMap fst ls)) \\ (fstSubst)-                   --There may be name clashing because of introducing new names.-                   clashedNames<-getClashedNames fstSubst newNames (ghead "foldParams" matches)--                   logm $ "MoveDef.foldParams about to foldInDemotedDecls"--                   -- decls' <- foldInDemotedDecls pns clashedNames subst decls-                   -- let demotedDecls''' = definingDeclsNames pns decls' True False-                   demotedDecls''' <- foldInDemotedDecls pns clashedNames subst [demotedDecls]-                   logm $ "MoveDef.foldParams foldInDemotedDecls done"--                   let [(GHC.L declSpan _)] = demotedDecls'''-                   declToks <- getToksForSpan declSpan-                   -- logm $ "MoveDef.foldParams addDecl adding to (hsBinds):[" ++ (SYB.showData SYB.Renamer 0 $ hsBinds rhs') ++ "]" -- ++AZ++-                   rhs'' <- addDecl rhs' Nothing (ghead "foldParams 2" demotedDecls''',[],Just declToks) False-                   logm $ "MoveDef.foldParams addDecl done 1"-                   return (GHC.Match pats mt rhs'')-           else  do  -- moveDecl pns match False decls True-                     -- return (HsMatch loc1 name pats rhs (ds++demotedDecls))  -- no parameter folding -                     -- logm $ "MoveDef.foldParams about to addDecl:dtoks=" ++ (show dtoks)-                     -- drawTokenTree "" -- ++AZ++ debug-                     rhs' <- addDecl rhs Nothing (demotedDecls,dsig,dtoks) False-                     logm $ "MoveDef.foldParams addDecl done 2"-                     return (GHC.Match pats mt rhs')--         -- return match-    where--       -- matchesInDecls ((Dec (HsFunBind loc matches))::HsDeclP)=matches-       matchesInDecls (GHC.FunBind _ _ (GHC.MatchGroup matches _) _ _ _) = matches-       matchesInDecls _x = []--       -- patsInMatch ((HsMatch loc1 name pats rhs ds)::HsMatchP)-       --   =pats-       patsInMatch (GHC.L _ (GHC.Match pats' _ _)) = pats'--       -- demotedDecls = map GHC.unLoc $ definingDeclsNames pns decls True False---       foldInDemotedDecls :: [GHC.Name]  -- ^The (list?) of names to be demoted-                          -> [GHC.Name]  -- ^Any names that clash-                          -> [(GHC.Name, GHC.HsExpr GHC.Name)] -- ^Parameter substitutions required-                          -> [GHC.LHsBind GHC.Name] -- ^Binds of original top level entiity, including src and dst-                          -> RefactGhc [GHC.LHsBind GHC.Name]-       foldInDemotedDecls  pns' clashedNames subst decls-          = everywhereMStaged SYB.Renamer (SYB.mkM worker) decls-          where-          -- worker (match@(HsMatch loc1 (PNT pname _ _) pats rhs ds)::HsMatchP)-          worker (match@(GHC.FunBind (GHC.L _ pname) _ (GHC.MatchGroup _matches _) _ _ _) :: GHC.HsBind GHC.Name)-            | isJust (find (==pname) pns')-            = do-                 match'  <- foldM (flip (autoRenameLocalVar True)) match clashedNames-                 match'' <- foldM replaceExpWithUpdToks match' subst-                 rmParamsInDemotedDecls (map fst subst) match''--          worker x = return x--      ------Get all of the paramaters supplied to pn ----------------------------            {- eg. sumSquares x1 y1 x2 y2 = rt x1 y1 + rt x2 y2-                   rt x y = x+y-              demote 'rt' to 'sumSquares',-              'allParams pn rhs []'  returns [[x1,x2],[y1,y2]]-                where pn is 'rt' and  rhs is 'rt x1 y1 + rt x2 y2'-           -}--       allParams :: GHC.Name -> GHC.GRHSs GHC.Name -> [[GHC.HsExpr GHC.Name]]-                 -> RefactGhc [[GHC.HsExpr GHC.Name]]-       allParams pn rhs1 initial  -- pn: demoted function/pattern name.-        =do -- p<-getOneParam pn rhs-            let p = getOneParam pn rhs1-            -- putStrLn (show p)-            if (nonEmptyList p) then do rhs' <- rmOneParam pn rhs1-                                        allParams pn rhs' (initial++[p])-                     else return initial-        where-           getOneParam :: (SYB.Data t) => GHC.Name -> t -> [GHC.HsExpr GHC.Name]-           getOneParam pn1-              = SYB.everythingStaged SYB.Renamer (++) []-                   ([] `SYB.mkQ`  worker)-              -- =applyTU (stop_tdTU (failTU `adhocTU` worker))-                where-                  worker :: GHC.HsExpr GHC.Name -> [GHC.HsExpr GHC.Name]-                  worker (GHC.HsApp e1 e2)-                   |(expToName e1==pn1) = [GHC.unLoc e2]-                  worker _ = []-           rmOneParam :: (SYB.Data t) => GHC.Name -> t -> RefactGhc t-           rmOneParam pn1 t-              -- This genuinely needs to be done once only. Damn.-              -- =applyTP (stop_tdTP (failTP `adhocTP` worker))-             = do-                -- _ <- clearRefactDone-                everywhereMStaged' SYB.Renamer (SYB.mkM worker) t-                where-                  {--                  worker :: GHC.HsExpr GHC.Name -> RefactGhc (GHC.HsExpr GHC.Name)-                  worker e@(GHC.HsApp e1 e2 ) = do -- The param being removed is e2-                    done <- getRefactDone-                    case (not done) && expToName e1==pn1 of-                      True ->  do setRefactDone-                                  return (GHC.unLoc e1)-                      False -> return e-                  worker x = return x-                  -}-                  worker (GHC.HsApp e1 _e2 ) -- The param being removed is e2-                    |expToName e1==pn1 = return (GHC.unLoc e1)-                  worker x = return x-{--              AST output--                 addthree x y z--              becomes--                  (HsApp-                    (L {test/testdata/Demote/WhereIn6.hs:10:17-28}-                     (HsApp-                      (L {test/testdata/Demote/WhereIn6.hs:10:17-26}-                       (HsApp-                        (L {test/testdata/Demote/WhereIn6.hs:10:17-24}-                         (HsVar {Name: WhereIn6.addthree}))-                        (L {test/testdata/Demote/WhereIn6.hs:10:26}-                         (HsVar {Name: x}))))-                      (L {test/testdata/Demote/WhereIn6.hs:10:28}-                       (HsVar {Name: y}))))-                    (L {test/testdata/Demote/WhereIn6.hs:10:30}-                     (HsVar {Name: z})))--------                  (HsApp-                     (HsApp-                       (HsApp-                         (HsVar {Name: WhereIn6.addthree}))-                         (HsVar {Name: x}))))-                       (HsVar {Name: y}))))-                     (HsVar {Name: z})))---------                  sq p x--               becomes--                  (HsApp-                   (HsApp-                     (HsVar {Name: Demote.WhereIn4.sq}))-                     (HsVar {Name: p}))))-                   (HsVar {Name: x})))-------                  sq x--               becomes--                  (HsApp-                   (HsVar {Name: sq}))-                   (HsVar {Name: x})))--}---       -----------remove parameters in demotedDecls--------------------------------       rmParamsInDemotedDecls :: [GHC.Name] -> GHC.HsBind GHC.Name-                              -> RefactGhc (GHC.HsBind GHC.Name)-       rmParamsInDemotedDecls ps bind-         -- = error $ "rmParamsInDemotedDecls: (ps,bind)=" ++ (showGhc (ps,bind)) -- ++AZ++-         -- =applyTP (once_tdTP (failTP `adhocTP` worker))-         = everywhereMStaged SYB.Renamer (SYB.mkM worker) bind-            -- where worker ((HsMatch loc1 name pats rhs ds)::HsMatchP)-            where worker (GHC.Match pats2 typ rhs1)-                    = do-                         let pats'=filter (\x->not ((patToPNT x /= Nothing) &&-                                          elem (gfromJust "rmParamsInDemotedDecls" $ patToPNT x) ps)) pats2--                         let (startPos,endPos) = getBiggestStartEndLoc pats2-                         if (emptyList pats')-                           then removeToksForPos (startPos,endPos)-                           else -- updateToksWithPos (startPos,endPos) pats' prettyprint False-                                updateToksWithPos (startPos,endPos) pats' pprPat False--                         -- pats'' <- update pats pats' pats--                         return (GHC.Match pats' typ rhs1)--       pprPat pat = intercalate " " $ map (\p -> (prettyprint p )) pat--       ----------remove parameters in the parent functions' rhs--------------------       --Attention: PNT i1 _ _==PNT i2 _ _ = i1 =i2-       rmParamsInParent :: GHC.Name -> [GHC.HsExpr GHC.Name] -> GHC.GRHSs GHC.Name-                        -> RefactGhc (GHC.GRHSs GHC.Name)-       rmParamsInParent pn es-         -- =applyTP (full_buTP (idTP `adhocTP` worker))-         = everywhereMStaged SYB.Renamer (SYB.mkM worker)-            where worker expr@(GHC.L _ (GHC.HsApp e1 e2))-                   -- was | findPN pn e1 && (elem (GHC.unLoc e2) es)-                   | findPN pn e1 && (elem (showGhc (GHC.unLoc e2)) (map (showGhc) es))-                      = update expr e1 expr-                  worker (expr@(GHC.L _ (GHC.HsPar e1)))-                    |pn==expToName e1-                       = update expr e1 expr-                  worker x =return x---       getClashedNames oldNames newNames match-         = do  (_f,d) <- hsFDsFromInside match-               -- ds' <- mapM (flip hsVisiblePNs match) oldNames-               ds' <- mapM (flip hsVisiblePNs match) oldNames-               -- return clashed names-               return (filter (\x->elem ({- pNtoName -} x) newNames)  --Attention: nub-                                   ( nub (d `union` (nub.concat) ds')))--       ----- make Substitions between formal and actual parameters.------------------       mkSubst :: [GHC.LPat GHC.Name] -> [[GHC.HsExpr GHC.Name]] -> [(GHC.Name,GHC.HsExpr GHC.Name)]-       mkSubst pats1 params-           = catMaybes (zipWith (\x y -> if (patToPNT x/=Nothing) && (length (nub $ map showGhc y)==1)-                                          then Just (gfromJust "mkSubst" $ patToPNT x,(ghead "mkSubst") y)-                                          else Nothing) pats1 params)----- |substitute an old expression by new expression-replaceExpWithUpdToks :: (SYB.Data t)-                      => t -> (GHC.Name, GHC.HsExpr GHC.Name)-                      -> RefactGhc t-replaceExpWithUpdToks  decls subst-  -- = applyTP (full_buTP (idTP `adhocTP` worker)) decls-  = everywhereMStaged' SYB.Renamer (SYB.mkM worker) decls-         where worker (e@(GHC.L l _)::GHC.LHsExpr GHC.Name)-                 |(expToName e/=defaultName) &&  (expToName e)==(fst subst)-                     = update e (GHC.L l (snd subst)) e-               worker x=return x----- | return True if pn is a local function/pattern name-isLocalFunOrPatName :: SYB.Data t => GHC.Name -> t -> Bool-isLocalFunOrPatName pn scope- = isLocalPN pn && isFunOrPatName pn scope---- ------------------------------------------------------------------------- |Divide a declaration list into three parts (before, parent, after)--- according to the PNT, where 'parent' is the first decl containing--- the PNT, 'before' are those decls before 'parent' and 'after' are--- those decls after 'parent'.--divideDecls ::-  SYB.Data t =>-  [t] -> GHC.Located GHC.Name -> ([t], [t], [t])-divideDecls ds pnt-  -- = error "undefined divideDecls"-  = let (before,after)=break (\x->findPNT pnt x) ds-    in if (not $ emptyList after)-         then (before, [ghead "divideDecls" after], tail after)-         else (ds,[],[])+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}++module Language.Haskell.Refact.Refactoring.MoveDef+  ( liftToTopLevel+  , liftOneLevel+  , demote+  -- ,liftingInClientMod+  ) where++import qualified Data.Generics as SYB+import qualified GHC.SYB.Utils as SYB+import qualified Data.Generics.Zipper as Z+++import qualified Exception             as GHC+import qualified FastString            as GHC+import qualified GHC                   as GHC+import qualified Name                  as GHC+import qualified RdrName               as GHC+import qualified TyCon                 as GHC+import qualified TypeRep               as GHC+import qualified Var                   as Var++import Control.Exception+import Control.Monad.State+import Data.Foldable+import Data.List+import Data.Maybe++import qualified Language.Haskell.GhcMod as GM+import Language.Haskell.Refact.API++import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint++import Data.Generics.Strafunski.StrategyLib.StrategyLib++import System.Directory++-- import Debug.Trace++-- ---------------------------------------------------------------------++-- data Direction = UptoTopLevel | UpOneLevel | Down++{--------This function handles refactorings involving moving a definition--------++ According to the Haskell's syntax, a declaration may occur in one of+the following six contexts:++  1. A top level declaration in the module:+        old: HsModule SrcLoc ModuleName (Maybe [HsExportSpecI i]) [HsImportDeclI i] ds+        new: (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], Maybe LHsDocString)+              HsGroup hs_valds :: HsValBinds id ...++  2. A local declaration in a Match: (of a FunBind)+        old: HsMatch SrcLoc i [p] (HsRhs e) ds+        new: Match [LPat id] (Maybe (LHsType id)) (GRHSs id)++  3. A local declaration in a pattern binding:+        old: HsPatBind SrcLoc p (HsRhs e) ds+        new: PatBind (LPat idL) (GRHSs idR) PostTcType NameSet (Maybe tickish)++  4. A local declaration in a Let expression:+        old: HsLet ds e+        new: HsLet (HsLocalBinds id) (LHsExpr id)++  5. A local declaration in a Case alternative:+        old: HsAlt SrcLoc p (HsRhs e) ds+        new: HsCase (LHsExpr id) (MatchGroup id)+           new is same as in a FunBind.++  6. A local declaration in a Do statement:+        old: HsLetStmt ds (HsStmt e p ds)+        new: LetStmt (HsLocalBindsLR idL idR)+             in context GRHS [LStmt id] (LHsExpr id)+-}++-- | Lift a definition to the top level+liftToTopLevel :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath]+liftToTopLevel settings opts fileName (row,col) = do+  absFileName <- canonicalizePath fileName+  runRefacSession settings opts (compLiftToTopLevel absFileName (row,col))++compLiftToTopLevel :: FilePath -> SimpPos+     -> RefactGhc [ApplyRefacResult]+compLiftToTopLevel fileName (row,col) = do+      parseSourceFileGhc fileName+      renamed <- getRefactRenamed+      parsed  <- getRefactParsed++      let (Just (modName,_)) = getModuleName parsed+      let maybePn = locToName (row, col) renamed+      case maybePn of+        Just pn -> liftToTopLevel' modName pn+        _       -> error "\nInvalid cursor position!\n"+++{- Refactoring Names: 'liftToTopLevel'++   This refactoring lifts a local function/pattern binding to the top+   level of the module, so as to make it accessible to other functions in+   the current module, and those modules that import current module.++   In the current implementation, a definition will be lifted only if+   none of the identifiers defined in this definition will cause name+   clash/capture problems in the current module after lifting.++   In the case that the whole current module is exported implicitly,+   the lifted identifier will be exported automatically after lifting. If+   the identifier will cause name clash/ambiguous occurrence problem in a+   client module, it will be hided in the import declaration of the+   client module (Note: this might not be the best solution, we prefer+   hiding it in the server module instead of in the client module in the+   final version).++   In the case of indirect importing, it might be time-consuming to+   trace whether the lifted identifier will cause any problem in a client+   module that indirectly imports the current module. The current+   solution is: suppose a defintion is lifted to top level in module A,+   and module A is imported and exported by module B, then the lifted+   identifier will be hided in the import declaration of B no matter+  whether it causes problems in module B or not.++   Function name: liftToTopLevel+   parameters: fileName--current file name.+               mod -- the scoped abstract syntax tree of the module.+               pn  -- the function/pattern name to be lifted.+-}+liftToTopLevel' :: GHC.ModuleName -- -> (ParseResult,[PosToken]) -> FilePath+                -> GHC.Located GHC.Name+                -> RefactGhc [ApplyRefacResult]+liftToTopLevel' modName pn@(GHC.L _ n) = do+  renamed <- getRefactRenamed+  targetModule <- getRefactTargetModule+  logm $ "liftToTopLevel':pn=" ++ (showGhc pn)+  if isLocalFunOrPatName n renamed+      then do+              (refactoredMod,declPns) <- applyRefac liftToMod RSAlreadyLoaded++              logm $ "liftToTopLevel' applyRefac done "++              if modIsExported modName renamed+               then do clients <- clientModsAndFiles targetModule+                       logm $ "liftToTopLevel':(clients,declPns)=" ++ (showGhc (clients,declPns))+                       refactoredClients <- mapM (liftingInClientMod modName declPns) clients+                       return (refactoredMod:(concat refactoredClients))+               else do return [refactoredMod]+      else error "\nThe identifier is not a local function/pattern name!"++    where+       {-step1: divide the module's top level declaration list into three parts:+         'parent' is the top level declaration containing the lifted declaration,+         'before' and `after` are those declarations before and after 'parent'.+         step2: get the declarations to be lifted from parent, bind it to liftedDecls+         step3: remove the lifted declarations from parent and extra arguments may be introduce.+         step4. test whether there are any names need to be renamed.+       -}+       liftToMod = do+         renamed <- getRefactRenamed+         parsed <- getRefactParsed+         declsp <- liftT $ hsDecls parsed+         (before,parent,after) <- divideDecls declsp pn+         {- ++AZ++ : hsBinds does not return class or instance definitions+         when (isClassDecl $ ghead "liftToMod" parent)+               $ error "Sorry, the refactorer cannot lift a definition from a class declaration!"+         when (isInstDecl $ ghead "liftToMod" parent)+               $ error "Sorry, the refactorer cannot lift a definition from an instance declaration!"+         -}+         nameMap <- getRefactNameMap+         -- declsParent <- liftT $ hsDecls (ghead "liftToMod" parent)+         -- logm $ "liftToMod:(declsParent)=" ++ (showGhc declsParent)+         let liftedDecls = definingDeclsRdrNames nameMap [n] parent True True+             declaredPns = nub $ concatMap (definedNamesRdr nameMap) liftedDecls+             liftedSigs  = definingSigsRdrNames nameMap declaredPns parent+             mLiftedSigs = liftedSigs++         -- TODO: what about declarations between this+         -- one and the top level that are used in this one?++         pns <- pnsNeedRenaming parsed parent liftedDecls declaredPns+         logm $ "liftToMod:(pns needing renaming)=" ++ (showGhc pns)++         let dd = getDeclaredVars $ hsBinds renamed+         logm $ "liftToMod:(ddd)=" ++ (showGhc dd)++         if pns == []+           then do+             (parent',liftedDecls',mLiftedSigs') <- addParamsToParentAndLiftedDecl n dd parent liftedDecls mLiftedSigs++             let defName  = (ghead "liftToMod" (definedNamesRdr nameMap (ghead "liftToMod2" parent')))+             parsed' <- liftT $ replaceDecls parsed (before++parent'++after)+             parsed2 <- moveDecl1 parsed' (Just defName) [GHC.unLoc pn] liftedDecls'+                                                            declaredPns mLiftedSigs'+             putRefactParsed parsed2 emptyAnns++             return declaredPns++           else askRenamingMsg pns "lifting"++++-- ---------------------------------------------------------------------++-- | Move a definition one level up from where it is now+liftOneLevel :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath]+liftOneLevel settings opts fileName (row,col) = do+  absFileName <- canonicalizePath fileName+  runRefacSession settings opts (compLiftOneLevel absFileName (row,col))++compLiftOneLevel :: FilePath -> SimpPos+     -> RefactGhc [ApplyRefacResult]+compLiftOneLevel fileName (row,col) = do+      parseSourceFileGhc fileName+      renamed <- getRefactRenamed+      parsed  <- getRefactParsed++      let (Just (modName,_)) = getModuleName parsed+      let maybePn = locToName (row, col) renamed+      case maybePn of+        Just pn ->  do+            rs <- liftOneLevel' modName pn+            logm $ "compLiftOneLevel:rs=" ++ (show $ (refactDone rs,map (\((_,d),_) -> d) rs))+            if (refactDone rs)+              then return rs+              else error ( "Lifting this definition failed. "+++                       " This might be because that the definition to be "+++                       "lifted is defined in a class/instance declaration.")+        _       ->  error "\nInvalid cursor position!\n"++{- Refactoring Names: 'liftOneLevel'+   Description:+    this refactoring lifts a local function/pattern binding only one level up.+    By 'lifting one-level up' , I mean:++    case1: In a module (HsModule SrcLoc ModuleName (Maybe [HsExportSpecI i]) [HsImportDeclI i] ds):+           A local declaration D  will be lifted to the same level as the 'ds', if D is in the+           where clause of one of ds's element declaration.++        new: (HsModule mmn mexp imps ds mdepr _haddock)+           In pactice this means processing++           a.  Matches in a FunBind+                 (Match mln pats _typ (GRHSs grhs ds))+           b. A PatBind+               (PatBind lhs (GRHSs grhs ds) _typ _fvs _ticks)++           and lifting a decl D from ds to the top.++           VarBinds and AbsBinds are introduced by the type checker, so can be ignored here.+           A PatSynBind does not have decls in it, so is ignored.+++    case2: In a match ( HsMatch SrcLoc i [p] (HsRhs e) ds) :+           A local declaration D  will be lifted to the same level as the 'ds', if D is in the+           where clause of one of ds's element declaration.+           A declaration D,say,in the rhs expression 'e' will be lifted to 'ds' if D is Not local to+           other declaration list in 'e'++           (in a FunBind)+        new: (Match mln pats _typ (GRHSs grhs lb))+++    case3: In a pattern  binding (HsPatBind SrcLoc p (HsRhs e) ds):+           A local declaration D  will be lifted to the same level as the 'ds', if D is in the+           where clause of one of ds's element declaration.+           A declaration D,say,in the rhs expression 'e' will be lifted to 'ds' if D is Not local to+           other declaration list in 'e'++        new: (PatBind lhs (GRHSs grhs ds) _typ _fvs _ticks)+++    case4: In the Let expression (Exp (HsLet ds e):+           A local declaration D  will be lifted to the same level as the 'ds', if D is in the+           where clause of one of ds's element declaration.+           A declaration D, say, in the expression 'e' will be lifted to 'ds' if D is not local to+           other declaration list in 'e'++        new: HsLet ds e+++    case5: In the case Alternative expression:(HsAlt loc p rhs ds)+           A local declaration D  will be lifted to the same level as the 'ds', if D is in the+           where clause of one of ds's element declaration.+           A declaration D in 'rhs' will be lifted to 'ds' if D is not local to other declaration+           list in 'rhs'.++        new: HsCase (LHsExpr id) (MatchGroup id)+           new is same as in a FunBind.+++    case6: In the do statement expression:(HsLetStmt ds stmts)+           A local declaration D  will be lifted to the same level as the 'ds', if D is in the+           where clause of one of ds's element declaration.+           A declaration D in 'stmts' will be lifted to 'ds' if D is not local to other declaration+           list in 'stmts'.++        new: LetStmt (HsLocalBindsLR idL idR)+             in context GRHS [LStmt id] (LHsExpr id)+++Function name: liftOneLevel+parameters: fileName--current file name.+            mod -- the scoped abstract syntax tree of the module.+            pn  -- the function/pattern name to be lifted.++-}++liftOneLevel' :: GHC.ModuleName+                -> GHC.Located GHC.Name+                -> RefactGhc [ApplyRefacResult]++liftOneLevel' modName pn@(GHC.L _ n) = do+  renamed <- getRefactRenamed+  targetModule <- getRefactTargetModule+  if isLocalFunOrPatName n renamed+        then do+                (refactoredMod,(b,pns)) <- applyRefac doLiftOneLevel RSAlreadyLoaded+                logm $ "liftOneLevel':main refactoring done:(p,pns)=" ++ showGhc (b,pns)+                if b &&  modIsExported modName renamed+                  then do+                          logm $ "liftOneLevel':looking for clients"+                          clients <- clientModsAndFiles targetModule+                          logm $ "liftOneLevel':(clients,pns)=" ++ (showGhc (clients,pns))+                          refactoredClients <- mapM (liftingInClientMod modName pns) clients+                          return (refactoredMod:concat refactoredClients)+                  else do return [refactoredMod]+        else error "\nThe identifer is not a function/pattern name!"++   where+      doLiftOneLevel = do+             logm $ "in doLiftOneLevel"+             parsed <- getRefactParsed+             logDataWithAnns "doLiftOneLevel:parsed" parsed+             nm <- getRefactNameMap+             ans <- liftT getAnnsT+             zp <- ztransformStagedM SYB.Parser+                                (Nothing+                                `SYB.mkQ`  (liftToModQ   nm ans)+                                `SYB.extQ` (liftToMatchQ nm ans)+                                `SYB.extQ` (liftToLetQ   nm ans)+                                ) (Z.toZipper parsed)+             let parsed' = Z.fromZipper zp+             putRefactParsed parsed' emptyAnns+             liftedToTopLevel pn parsed'++           where+             isMatch :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Bool+             isMatch _ = True++             isHsLet :: GHC.LHsExpr GHC.RdrName -> Bool+             isHsLet (GHC.L _ (GHC.HsLet _ _)) = True+             isHsLet _               = False++             -- ------------------------++             liftToModQ ::+                           NameMap -> Anns+                        -> GHC.ParsedSource+                        -> Maybe (SYB.Stage+                                  -> Z.Zipper GHC.ParsedSource+                                  -> RefactGhc (Z.Zipper GHC.ParsedSource))+             liftToModQ nm ans (p :: GHC.ParsedSource)+                | nonEmptyList candidateBinds+                  = Just (doLiftZ p declsp)+                | otherwise = Nothing+                where+                 (declsp ,_,_) = runTransform ans (hsDecls p)+                 doOne bs = (definingDeclsRdrNames nm [n] declsbs False False,bs)+                   where+                     (declsbs,_,_) = runTransform ans (hsDeclsGeneric bs)++                 candidateBinds = map snd+                                $ filter (\(l,_bs) -> nonEmptyList l)+                                $ map doOne+                                $ declsp++             getHsDecls ans t = decls+               where (decls,_,_) = runTransform ans (hsDeclsGeneric t)++             -- ------------------------++             liftToMatchQ :: (SYB.Data a)+                          => NameMap -> Anns+                          -> GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)+                          -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a))+             liftToMatchQ nm ans (m@(GHC.L _ (GHC.Match _ _pats _mtyp (GHC.GRHSs _rhs ds)))::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))+                 | (nonEmptyList (definingDeclsRdrNames nm [n] (getHsDecls ans  ds) False False))+                    = Just (doLiftZ m (getHsDecls ans  ds))+                 | otherwise = Nothing++             -- ------------------------++             liftToLetQ :: SYB.Data a+                        => NameMap -> Anns+                        -> GHC.LHsExpr GHC.RdrName -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a))+             liftToLetQ nm ans ll@(GHC.L _ (GHC.HsLet ds _e))+               | nonEmptyList (definingDeclsRdrNames nm [n] (getHsDecls ans ds) False  False)+                 = Just (doLiftZ ll (getHsDecls ans ll))+               | otherwise = Nothing+             liftToLetQ _ _ _ = Nothing++             -- ------------------------++             doLiftZ :: (SYB.Data t,SYB.Data a)+               => t -- ^Item containing the decls which contain the ones to be lifted+               -> [GHC.LHsDecl GHC.RdrName] -- ^decls containing the ones to be lifted.+                                            -- ++AZ++:TODO: these are redundant, can be pulled out of t+               -> SYB.Stage -- ++AZ++:TODO: get rid of this+               -> Z.Zipper a+               -> RefactGhc (Z.Zipper a)+             doLiftZ ds decls _stage z =+                  do+                    logm $ "doLiftZ entered"+                    logDataWithAnns "doLiftZ:ds" ds+                    logDataWithAnns "doLiftZ:decls" decls++                    let zu = case (Z.up z) of+                              Just zz -> fromMaybe (error $ "MoveDef.liftToLet.1" ++ SYB.showData SYB.Parser 0 decls)+                                  $ upUntil (False `SYB.mkQ` isMatch+                                                   `SYB.extQ` isHsLet+                                                   )+                                     zz+                              Nothing -> z++                    let+                      wtop (ren::GHC.ParsedSource) = do+                        logm $ "wtop entered"+                        nm <- getRefactNameMap+                        let (_,DN dd) = (hsFreeAndDeclaredRdr nm ren)+                        -- ++AZ++ : TODO: get rid of worker in favour of+                        -- workerTop+                        worker ren decls pn dd+                        -- workerTop ren decls dd+++                      wmatch :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)+                             -> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))+                      wmatch (m@(GHC.L _ (GHC.Match _mln _pats _typ grhss))) = do+                         logm $ "wmatch entered:" ++ SYB.showData SYB.Parser 0 m+                         nm <- getRefactNameMap+                         let (_,DN dd) = hsFreeAndDeclaredRdr nm grhss++                         decls' <- liftT $ hsDecls m+                         workerTop m decls' dd++                      wlet :: GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName)+                      wlet l@(GHC.L _ (GHC.HsLet dsl _e)) = do+                         logm $ "wlet entered "+                         nm <- getRefactNameMap+                         let (_,DN dd) = hsFreeAndDeclaredRdr nm dsl+                         dsl' <- workerTop l decls dd+                         return dsl'+                      wlet x = return x++                    ds' <- Z.transM ( SYB.mkM   wtop+                                     `SYB.extM` wmatch+                                     `SYB.extM` wlet+                                    ) zu++                    return ds'++             -- ----------------------------------------+++             -- This is currently used for everything but the top level+             workerTop :: (HasDecls t)+                => t -- ^The destination of the lift operation+                -> [GHC.LHsDecl GHC.RdrName] -- ^ list containing the decl to be+                                             -- lifted+                -> [GHC.Name] -- ^Declared variables in the destination+                -> RefactGhc t+             workerTop dest ds dd+                  =do+                      logm $ "MoveDef.worker: dest" ++ SYB.showData SYB.Parser 0 dest+                      logm $ "MoveDef.workerTop: ds=" ++ (showGhc ds)+                      done <- getRefactDone+                      if done then return dest+                        else do+                          setRefactDone+                          let parent = dest+                          nm <- getRefactNameMap+                          let liftedDecls = definingDeclsRdrNames' nm [n] parent+                              declaredPns = nub $ concatMap (definedNamesRdr nm) liftedDecls+                          logm $ "MoveDef.workerTop: n=" ++ (showGhc n)+                          logm $ "MoveDef.workerTop: liftedDecls=" ++ (showGhc liftedDecls)+                          pns <- pnsNeedRenaming dest parent liftedDecls declaredPns+                          logm $ "MoveDef.workerTop: pns=" ++ (showGhc pns)+                          if pns==[]+                            then do+                                    (parent',liftedDecls',mLiftedSigs')<-addParamsToParentAndLiftedDecl n dd+                                                                         parent liftedDecls []+                                    logm $ "MoveDef.workerTop: liftedDecls'=" ++ (showGhc liftedDecls')+                                    --True means the new decl will be at the same level with its parant.+                                    let toMove = parent'+                                    pdecls <- liftT $ hsDecls toMove+                                    -- logm $ "MoveDef.workerTop:toMove=" ++ SYB.showData SYB.Parser 0 toMove+                                    -- logm $ "MoveDef.workerTop:pdecls=" ++ (showGhc pdecls)+                                    let mAfter = case pdecls of+                                          [] -> Nothing+                                          _ -> (Just (ghead "worker" (definedNamesRdr nm (glast "workerTop" ds))))+                                    dest' <- moveDecl1 toMove+                                               mAfter+                                               [n] liftedDecls' declaredPns mLiftedSigs'+                                    return dest'+                            else askRenamingMsg pns "lifting"++             -- ----------------------------------------++             -- TODO: get rid of this in favour of workerTop+             worker :: (HasDecls t)+                => t -- ^The destination of the lift operation+                -> [GHC.LHsDecl GHC.RdrName] -- ^ list containing the decl to be+                                             -- lifted+                -> GHC.Located GHC.Name -- ^ The name of the decl to be lifted+                -> [GHC.Name] -- ^Declared variables in the destination+                -> RefactGhc t+             worker dest ds pnn dd+                  =do+                      -- logm $ "MoveDef.worker: dest" ++ (showGhc dest)+                      logm $ "MoveDef.worker: ds=" ++ (showGhc ds)+                      done <- getRefactDone+                      if done then return dest+                        else do+                          setRefactDone+                          (before,parent,after) <- divideDecls ds pnn -- parent is misnomer, it is the decl to be moved+                          logm $ "MoveDef.worker:(before,parent,after)" ++ showGhc (before,parent,after)+                          nm <- getRefactNameMap+                          let liftedDecls = definingDeclsRdrNames nm [n] parent True True+                              declaredPns = nub $ concatMap (definedNamesRdr nm) liftedDecls+                          pns <- pnsNeedRenaming dest parent liftedDecls declaredPns+                          logm $ "MoveDef.worker: pns=" ++ (showGhc pns)+                          if pns==[]+                            then do+                                    (parent',liftedDecls',mLiftedSigs')<-addParamsToParentAndLiftedDecl n dd+                                                                         parent liftedDecls []+                                    --True means the new decl will be at the same level with its parant.+                                    toMove <- liftT $ replaceDecls dest (before++parent'++after)+                                    dest' <- moveDecl1 toMove+                                               (Just (ghead "worker" (definedNamesRdr nm (ghead "worker" parent'))))+                                               [n] liftedDecls' declaredPns mLiftedSigs'+                                    return dest'+                            else askRenamingMsg pns "lifting"+++-- ---------------------------------------------------------------------++-- | Move a definition one level down+demote :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath]+demote settings opts fileName (row,col) = do+  absFileName <- canonicalizePath fileName+  runRefacSession settings opts (compDemote absFileName (row,col))++compDemote ::FilePath -> SimpPos+         -> RefactGhc [ApplyRefacResult]+compDemote fileName (row,col) = do+      parseSourceFileGhc fileName+      renamed <- getRefactRenamed+      parsed  <- getRefactParsed++      -- TODO: make the next one an API call, that also gets the+      -- parsed source+      let (Just (modName,_)) = getModuleName parsed+      let maybePn = locToName (row, col) renamed+      case maybePn of+        Just pn -> demote' modName pn+        _       -> error "\nInvalid cursor position!\n"++-- ---------------------------------------------------------------------++moveDecl1 :: (SYB.Data t)+  => t -- ^ The syntax element to update+  -> Maybe GHC.Name -- ^ If specified, add defn after this one++  -> [GHC.Name]     -- ^ The first one is the decl to move+  -> [GHC.LHsDecl GHC.RdrName]+  -> [GHC.Name]     -- ^ The signatures to remove. May be multiple if+                    --   decl being moved has a patbind.+  -> [GHC.LSig GHC.RdrName] -- ^ lifted decls signature if present+  -> RefactGhc t    -- ^ The updated syntax element (and tokens in monad)+moveDecl1 t defName ns mliftedDecls sigNames mliftedSigs = do+  logm $ "moveDecl1:(defName,ns,sigNames,mliftedDecls)=" ++ showGhc (defName,ns,sigNames,mliftedDecls)+  logm $ "moveDecl1:(t)=" ++ SYB.showData SYB.Parser 0 (t)++  -- TODO: rmDecl can now remove the sig at the same time.+  (t'',_sigsRemoved) <- rmTypeSigs sigNames t+  -- logm $ "moveDecl1:after rmTypeSigs:t''" ++ SYB.showData SYB.Parser 0 t''+  logm $ "moveDecl1:mliftedSigs=" ++ showGhc mliftedSigs+  (t',_declRemoved,_sigRemoved) <- rmDecl (ghead "moveDecl3.1"  ns) False t''+  logm $ "moveDecl1:after rmDecl:t'" ++ SYB.showData SYB.Parser 0 t'+  let sigs = map wrapSig mliftedSigs+  r <- addDecl t' defName (sigs++mliftedDecls,Nothing)++  return r++-- ---------------------------------------------------------------------++askRenamingMsg :: [GHC.Name] -> String -> t+askRenamingMsg pns str+  = error ("The identifier(s): " ++ (intercalate "," $ map showPN pns) +++           " will cause name clash/capture or ambiguity occurrence problem after "+           ++ str ++", please do renaming first!")++  where+    showPN pn = showGhc (pn,GHC.nameSrcLoc pn)++-- |Get the subset of 'pns' that need to be renamed before lifting.+pnsNeedRenaming :: (SYB.Data t1,SYB.Data t2) =>+  t1 -> t2 -> t3 -> [GHC.Name]+  -> RefactGhc [GHC.Name]+pnsNeedRenaming dest parent _liftedDecls pns+  = do+       logm $ "MoveDef.pnsNeedRenaming entered:pns=" ++ showGhc pns+       r <- mapM pnsNeedRenaming' pns+       return (concat r)+  where+     pnsNeedRenaming' pn+       = do+            logm $ "MoveDef.pnsNeedRenaming' entered"+            nm <- getRefactNameMap+            (FN f,DN d) <- hsFDsFromInsideRdr nm dest --f: free variable names that may be shadowed by pn+                                                      --d: declaread variables names that may clash with pn+            logm $ "MoveDef.pnsNeedRenaming':(f,d)=" ++ showGhc (f,d)+            vs <- hsVisiblePNsRdr nm pn parent  --vs: declarad variables that may shadow pn+            logm $ "MoveDef.pnsNeedRenaming':vs=" ++ showGhc vs+            let vars = map pNtoName (nub (f `union` d `union` vs) \\ [pn]) -- `union` inscpNames+            isInScope <- isInScopeAndUnqualifiedGhc (pNtoName pn) Nothing+            logm $ "MoveDef.pnsNeedRenaming:(f,d,vs,vars,isInScope)=" ++ (showGhc (f,d,vs,vars,isInScope))+            if elem (pNtoName pn) vars  || isInScope && findEntity pn dest+               then return [pn]+               else return []+     pNtoName = showGhc++-- ---------------------------------------------------------------------++addParamsToParent :: (SYB.Data t) => GHC.Name -> [GHC.RdrName] -> t -> RefactGhc t+addParamsToParent _pn [] t = return t+addParamsToParent  pn params t = do+  logm $ "addParamsToParent:(pn,params)" ++ (showGhc (pn,params))+  addActualParamsToRhs pn params t+++-- |Do refactoring in the client module. that is to hide the identifer+-- in the import declaration if it will cause any problem in the+-- client module.+liftingInClientMod :: GHC.ModuleName -> [GHC.Name] -> TargetModule+  -> RefactGhc [ApplyRefacResult]+liftingInClientMod serverModName pns targetModule = do+       logm $ "liftingInClientMod:targetModule=" ++ (show targetModule)+       getTargetGhc targetModule+       parsed <- getRefactParsed+       clientModule <- getRefactModule+       logm $ "liftingInClientMod:clientModule=" ++ (showGhc clientModule)+       modNames <- willBeUnQualImportedBy serverModName+       logm $ "liftingInClientMod:modNames=" ++ (showGhc modNames)+       if isJust modNames+        then do+             pns' <- namesNeedToBeHided clientModule (gfromJust "liftingInClientMod" modNames) pns+             let pnsRdr' = map GHC.nameRdrName pns'+             logm $ "liftingInClientMod:pns'=" ++ (showGhc pns')+             if (nonEmptyList pns')+                 then do (refactoredMod,_) <- applyRefac (addHiding serverModName parsed pnsRdr') RSAlreadyLoaded+                         return [refactoredMod]+                 else return []+        else return []++-- ---------------------------------------------------------------------++-- |Test whether an identifier defined in the modules specified by+-- 'names' will be exported by current module.+willBeExportedByClientMod :: [GHC.ModuleName] -> GHC.RenamedSource -> Bool+willBeExportedByClientMod names renamed =+  let (_,_,exps,_) = renamed+  in if isNothing exps+        then False+        else any isJust $ map (\y-> (find (\x-> (simpModule x==Just y)) (gfromJust "willBeExportedByClientMod" exps))) names+     where simpModule (GHC.L _ (GHC.IEModuleContents (GHC.L _ m))) = Just m+           simpModule _  = Nothing++-- |get the module name or alias name by which the lifted identifier+-- will be imported automatically.+-- TODO: maybe move this into TypeUtils+-- willBeUnQualImportedBy::HsName.ModuleName->HsModuleP->Maybe [HsName.ModuleName]+willBeUnQualImportedBy :: GHC.ModuleName -> RefactGhc (Maybe [GHC.ModuleName])+willBeUnQualImportedBy modName = do+   (_,imps,_,_) <- getRefactRenamed+   let ms = filter (\(GHC.L _ (GHC.ImportDecl _ (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as h))+                     -> modName == modName1 && (not isQualified) && (isNothing h || (isJust h && ((fst (fromJust h)) == True))))+                   imps++       res = if (emptyList ms) then Nothing+                               else Just $ nub $ map getModName ms++       getModName (GHC.L _ (GHC.ImportDecl _ (GHC.L _ modName2) _qualify _source _safe _isQualified _isImplicit as _h))+        = if isJust as then simpModName (fromJust as)+                       else modName2++       simpModName m = m++   logm $ "willBeUnQualImportedBy:(ms,res)=" ++ (showGhc (ms,res))++   return res++-- ---------------------------------------------------------------------++-- |get the subset of 'pns', which need to be hided in the import+-- declaration in module 'mod'+-- Note: these are newly exported from the module, so we cannot use+-- the GHC name resolution i nthis case.+namesNeedToBeHided :: GHC.Module -> [GHC.ModuleName] -> [GHC.Name]+   -> RefactGhc [GHC.Name]+namesNeedToBeHided clientModule modNames pns = do+  renamed <- getRefactRenamed+  parsed <- getRefactParsed+  logm $ "namesNeedToBeHided:willBeExportedByClientMod=" ++ (show $ willBeExportedByClientMod modNames renamed)+  gnames <- GHC.getNamesInScope+  let clientInscopes = filter (\n -> clientModule == GHC.nameModule n) gnames+  logm $ "namesNeedToBeHided:(clientInscopes)=" ++ (showGhc (clientInscopes))++  pnsMapped <- mapM getLocalEquiv pns+  logm $ "namesNeedToBeHided:pnsMapped=" ++ (showGhc pnsMapped)++  let pnsMapped' = filter (\(_,_,ns) -> not $ emptyList ns) pnsMapped++  if willBeExportedByClientMod modNames renamed+      then return pns+      else do+        ff <- mapM (needToBeHided parsed) pnsMapped'+        return $ concat ff+  where+    -- | Strip the package prefix from the name and return the+    -- stripped name together with any names in the local module that+    -- may match the stripped one+    getLocalEquiv :: GHC.Name -> RefactGhc (GHC.Name,String,[GHC.Name])+    getLocalEquiv pn = do+      let pnStr = stripPackage $ showGhc pn+      logm $ "MoveDef getLocalEquiv: about to parseName:" ++ (show pnStr)+      ecns <- GHC.gtry $ GHC.parseName pnStr+      let cns = case ecns of+                 Left (_e::SomeException) -> []+                 Right v -> v+      logm $ "MoveDef getLocalEquiv: cns:" ++ (showGhc cns)+      return (pn,pnStr,cns)++    stripPackage :: String -> String+    stripPackage str = reverse s+      where+        (s,_) = break (== '.') $ reverse str++    needToBeHided :: GHC.ParsedSource -> (GHC.Name,String,[GHC.Name]) -> RefactGhc [GHC.Name]+    needToBeHided parsed (pn,_pnStr,pnsLocal) = do+      let uwoq = map (\n -> usedWithoutQualR n parsed) pnsLocal++      -- logm $ "needToBeHided:(hsBinds renamed)=" ++ (showGhc (hsBinds renamed))+      logm $ "needToBeHided:(pn,uwoq)=" ++ (showGhc (pn,uwoq))++      if (any (== True) uwoq --the same name is used in the module unqualifiedly or+                --is exported unqualifiedly by an Ent decl++            -- TODO: ++AZ++ check if next line needs to be reinstated+            -- was || any (\m -> causeNameClashInExports oldPN pn m renamed) modNames)+            || False)+           then return [pn]+           else return []+++-- **************************************************************************************************************--++-- ---------------------------------------------------------------------++liftedToTopLevel :: GHC.Located GHC.Name -> GHC.ParsedSource -> RefactGhc (Bool,[GHC.Name])+liftedToTopLevel pnt@(GHC.L _ pn) parsed = do+  -- logm $ "liftedToTopLevel entered"+  nm <- getRefactNameMap+  -- logm $ "liftedToTopLevel:got nm"+  decls <- liftT $ hsDecls parsed+  let topDecs = definingDeclsRdrNames nm [pn] decls False False+  -- ++AZ++ :TODO: we are not updating the nameMap to reflect moved decls+  if nonEmptyList topDecs+     then do+       (_, parent,_) <- divideDecls decls pnt+       let declsp = parent+       let liftedDecls = definingDeclsRdrNames nm [pn] declsp False False+           declaredPns  = nub $ concatMap (definedNamesRdr nm) liftedDecls+       return (True, declaredPns)+     else return (False, [])++-- ---------------------------------------------------------------------++addParamsToParentAndLiftedDecl :: (SYB.Data t) =>+     GHC.Name   -- ^name of decl being lifted+  -> [GHC.Name] -- ^Declared names in parent+  -> t          -- ^parent+  -> [GHC.LHsDecl GHC.RdrName] -- ^ decls being lifted+  -> [GHC.LSig GHC.RdrName]    -- ^ lifted decls signature if present+  -> RefactGhc (t, [GHC.LHsDecl GHC.RdrName], [GHC.LSig GHC.RdrName])+addParamsToParentAndLiftedDecl pn dd parent liftedDecls mLiftedSigs+  =do+       logm $ "addParamsToParentAndLiftedDecl:liftedDecls=" ++ (showGhc liftedDecls)+       nm <- getRefactNameMap+       let (FN ef,_) = hsFreeAndDeclaredRdr nm parent+       let (FN lf,_) = hsFreeAndDeclaredRdr nm liftedDecls++       logm $ "addParamsToParentAndLiftedDecl:(ef,lf)=" ++ showGhc (ef,lf)++       -- parameters to be added to pn because of lifting+       let newParamsNames = ((nub lf) \\ (nub ef)) \\ dd+           newParams = map GHC.nameRdrName newParamsNames++       logm $ "addParamsToParentAndLiftedDecl:(newParams,ef,lf,dd)=" ++ (showGhc (newParams,ef,lf,dd))++       if newParams /= []+         then if  (any isComplexPatDecl liftedDecls)+                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++                        parent' <- addParamsToParent pn newParams parent''++                        liftedDecls' <- addParamsToDecls [liftedDecls''] pn newParams++                        mLiftedSigs' <- mapM (addParamsToSigs newParamsNames) mLiftedSigs++                        logm $ "addParamsToParentAndLiftedDecl:mLiftedSigs'=" ++ showGhc mLiftedSigs'++                        return (parent',liftedDecls', mLiftedSigs')+         else return (parent,liftedDecls,mLiftedSigs)++-- ---------------------------------------------------------------------++-- TODO: perhaps move this to TypeUtils+addParamsToSigs :: [GHC.Name] -> GHC.LSig GHC.RdrName -> RefactGhc (GHC.LSig GHC.RdrName)+addParamsToSigs [] ms = return ms+addParamsToSigs newParams (GHC.L l (GHC.TypeSig lns ltyp pns)) = do+  mts <- mapM getTypeForName newParams+  let ts = catMaybes mts+  logm $ "addParamsToSigs:ts=" ++ showGhc ts+  logDataWithAnns "addParamsToSigs:ts=" ts+  let newStr = ":: " ++ (intercalate " -> " $ map printSigComponent ts) ++ " -> "+  logm $ "addParamsToSigs:newStr=[" ++ newStr ++ "]"+  typ' <- liftT $ foldlM addOneType ltyp (reverse ts)+  sigOk <- isNewSignatureOk ts+  logm $ "addParamsToSigs:(sigOk,newStr)=" ++ show (sigOk,newStr)+  if sigOk+    then return (GHC.L l (GHC.TypeSig lns typ' pns))+    else error $ "\nNew type signature may fail type checking: " ++ newStr ++ "\n"+  where+    addOneType :: GHC.LHsType GHC.RdrName -> GHC.Type -> Transform (GHC.LHsType GHC.RdrName)+    addOneType et t = do+      hst <- typeToLHsType t+      ss1 <- uniqueSrcSpanT+      hst1 <- case t of+        (GHC.FunTy _ _) -> do+          ss <- uniqueSrcSpanT+          let t1 = GHC.L ss (GHC.HsParTy hst)+          setEntryDPT hst (DP (0,0))+          addSimpleAnnT t1  (DP (0,0)) [((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))]+          return t1+        _ -> return hst+      let typ = GHC.L ss1 (GHC.HsFunTy hst1 et)++      addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnRarrow),DP (0,1))]+      return typ++addParamsToSigs np ls = error $ "addParamsToSigs: no match for:" ++ showGhc (np,ls)++-- ---------------------------------------------------------------------++printSigComponent :: GHC.Type -> String+printSigComponent x = ppType x++-- ---------------------------------------------------------------------++-- |Fail any signature having a forall in it.+-- TODO: this is unnecesarily restrictive, but needs+-- a) proper reversing of GHC.Type to GHC.LhsType+-- b) some serious reverse type inference to ensure that the+--    constraints are modified properly to merge the old signature+--    part and the new.+isNewSignatureOk :: [GHC.Type] -> RefactGhc Bool+isNewSignatureOk types = do+  -- NOTE: under some circumstances enabling Rank2Types or RankNTypes+  --       can resolve the type conflict, this can potentially be checked+  --       for.+  -- NOTE2: perhaps proceed and reload the tentative refactoring into+  --        the GHC session and accept it only if it type checks+  let+    r = SYB.everythingStaged SYB.TypeChecker (++) []+          ([] `SYB.mkQ` usesForAll) types+    usesForAll (GHC.ForAllTy _ _) = [1::Int]+    usesForAll _                  = []++  return $ emptyList r++-- ---------------------------------------------------------------------++-- TODO: perhaps move this to TypeUtils+-- TODO: complete this+typeToLHsType :: GHC.Type -> Transform (GHC.LHsType GHC.RdrName)+typeToLHsType (GHC.TyVarTy v)   = do+  ss <- uniqueSrcSpanT+  let typ = GHC.L ss (GHC.HsTyVar (GHC.nameRdrName $ Var.varName v))+  addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,0))]+  return typ++typeToLHsType (GHC.AppTy t1 t2) = do+  t1' <- typeToLHsType t1+  t2' <- typeToLHsType t2+  ss <- uniqueSrcSpanT+  return $ GHC.L ss (GHC.HsAppTy t1' t2')++typeToLHsType t@(GHC.TyConApp _tc _ts) = tyConAppToHsType t++typeToLHsType (GHC.FunTy t1 t2) = do+  t1' <- typeToLHsType t1+  t2' <- typeToLHsType t2+  ss <- uniqueSrcSpanT+  let typ = GHC.L ss (GHC.HsFunTy t1' t2')+  addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnRarrow),DP (0,1))]+  return typ++typeToLHsType (GHC.ForAllTy _v t) = do+  t' <- typeToLHsType t+  ss1 <- uniqueSrcSpanT+  ss2 <- uniqueSrcSpanT+  return $ GHC.L ss1 (GHC.HsForAllTy GHC.Explicit Nothing (GHC.HsQTvs [] []) (GHC.L ss2 []) t')++typeToLHsType (GHC.LitTy (GHC.NumTyLit i)) = do+  ss <- uniqueSrcSpanT+  let typ = GHC.L ss (GHC.HsTyLit (GHC.HsNumTy (show i) i)) :: GHC.LHsType GHC.RdrName+  addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,0))]+  return typ++typeToLHsType (GHC.LitTy (GHC.StrTyLit s)) = do+  ss <- uniqueSrcSpanT+  let typ = GHC.L ss (GHC.HsTyLit (GHC.HsStrTy "" s)) :: GHC.LHsType GHC.RdrName+  addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,0))]+  return typ+++{-+data Type+  = TyVarTy Var	-- ^ Vanilla type or kind variable (*never* a coercion variable)++  | AppTy         -- See Note [AppTy invariant]+	Type+	Type		-- ^ Type application to something other than a 'TyCon'. Parameters:+	                --+                        --  1) Function: must /not/ be a 'TyConApp',+                        --     must be another 'AppTy', or 'TyVarTy'+	                --+	                --  2) Argument type++  | TyConApp      -- See Note [AppTy invariant]+	TyCon+	[KindOrType]	-- ^ Application of a 'TyCon', including newtypes /and/ synonyms.+	                -- Invariant: saturated appliations of 'FunTyCon' must+	                -- use 'FunTy' and saturated synonyms must use their own+                        -- constructors. However, /unsaturated/ 'FunTyCon's+                        -- do appear as 'TyConApp's.+	                -- Parameters:+	                --+	                -- 1) Type constructor being applied to.+	                --+                        -- 2) Type arguments. Might not have enough type arguments+                        --    here to saturate the constructor.+                        --    Even type synonyms are not necessarily saturated;+                        --    for example unsaturated type synonyms+	                --    can appear as the right hand side of a type synonym.++  | FunTy+	Type+	Type		-- ^ Special case of 'TyConApp': @TyConApp FunTyCon [t1, t2]@+			-- See Note [Equality-constrained types]++  | ForAllTy+	Var         -- Type or kind variable+	Type	        -- ^ A polymorphic type++  | LitTy TyLit     -- ^ Type literals are simillar to type constructors.++-}++tyConAppToHsType :: GHC.Type -> Transform (GHC.LHsType GHC.RdrName)+tyConAppToHsType (GHC.TyConApp tc _ts) = r (show $ GHC.tyConName tc)+  where+    r str = do+      ss <- uniqueSrcSpanT+      let typ = GHC.L ss (GHC.HsTyLit (GHC.HsStrTy str $ GHC.mkFastString str)) :: GHC.LHsType GHC.RdrName+      addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,1))]+      return typ++-- tyConAppToHsType t@(GHC.TyConApp _tc _ts)+--    = error $ "tyConAppToHsType: unexpected:" ++ (SYB.showData SYB.TypeChecker 0 t)++{-+HsType+HsForAllTy HsExplicitFlag (LHsTyVarBndrs name) (LHsContext name) (LHsType name)+HsTyVar name+HsAppTy (LHsType name) (LHsType name)+HsFunTy (LHsType name) (LHsType name)+HsListTy (LHsType name)+HsPArrTy (LHsType name)+HsTupleTy HsTupleSort [LHsType name]+HsOpTy (LHsType name) (LHsTyOp name) (LHsType name)+HsParTy (LHsType name)+HsIParamTy HsIPName (LHsType name)+HsEqTy (LHsType name) (LHsType name)+HsKindSig (LHsType name) (LHsKind name)+HsQuasiQuoteTy (HsQuasiQuote name)+HsSpliceTy (HsSplice name) FreeVars PostTcKind+HsDocTy (LHsType name) LHsDocString+HsBangTy HsBang (LHsType name)+HsRecTy [ConDeclField name]+HsCoreTy Type+HsExplicitListTy PostTcKind [LHsType name]+HsExplicitTupleTy [PostTcKind] [LHsType name]+HsTyLit HsTyLit+HsWrapTy HsTyWrapper (HsType name)+-}+++--------------------------------End of Lifting-----------------------------------------++{-Refactoring : demote a function/pattern binding(simpe or complex) to the declaration where it is used.+  Descritption: if a declaration D, say, is only used by another declaration F,say, then D can be+                demoted into the local declaration list (where clause) in F.+                So currently, D can not be demoted if more than one declaration use it.++                In a multi-module context, a top-level definition can not be demoted if it is used+                by other modules. In the case that the demoted identifer is in the hiding list of+                import declaration in a client module, it should be removed from the hiding list.++ Function name:demote+ parameters: fileName--current file name.+             mod -- the scoped abstract syntax tree of the module.+             pn  -- the function/pattern name to be demoted.++-}++demote' ::+     GHC.ModuleName+  -- -> FilePath+  -- -> (ParseResult,[PosToken])+  -> GHC.Located GHC.Name+  -> RefactGhc [ApplyRefacResult]+demote' modName (GHC.L _ pn) = do+  renamed <- getRefactRenamed+  targetModule <- getRefactTargetModule+  if isFunOrPatName pn renamed+    then do+       isTl <- isTopLevelPN pn+       if isTl && isExplicitlyExported pn renamed+          then error "This definition can not be demoted, as it is explicitly exported by the current module!"+          else do+                  (refactoredMod,declaredPns) <- applyRefac (doDemoting pn) RSAlreadyLoaded+                  if isTl && modIsExported modName renamed+                    then do+                            logm $ "demote':isTl && isExported"+                            clients <- clientModsAndFiles targetModule+                            logm $ "demote':clients=" ++ (showGhc clients)+                            refactoredClients <-mapM (demotingInClientMod declaredPns) clients+                            return (refactoredMod:refactoredClients)+                    else do return [refactoredMod]+    else error "\nInvalid cursor position!"+++-- |Do refactoring in the client module, that is:+--  a) Check whether the identifier is used in the module body+--  b) If the identifier is not used but is hided by the import+--     declaration, then remove it from the hiding.+demotingInClientMod ::+  [GHC.Name] -> TargetModule+  -> RefactGhc ApplyRefacResult+demotingInClientMod pns targetModule = do+  logm $ "demotingInClientMod:(pns,targetModule)=" ++ showGhc (pns,targetModule)+  getTargetGhc targetModule+  modu <- getRefactModule+  (refactoredMod,_) <- applyRefac (doDemotingInClientMod pns modu) RSAlreadyLoaded+  return refactoredMod+++doDemotingInClientMod :: [GHC.Name] -> GHC.Module -> RefactGhc ()+doDemotingInClientMod pns modName = do+  logm $ "doDemotingInClientMod:(pns,modName)=" ++ showGhc (pns,modName)+  renamed@(_g,imps,exps,_docs) <- getRefactRenamed+  if any (\pn->findPN pn (hsBinds renamed) || findPN pn (exps)) pns+     then error $ "This definition can not be demoted, as it is used in the client module '"++(showGhc modName)++"'!"+     else if any (\pn->findPN pn imps) pns+             -- TODO: reinstate this+             then do -- (mod',((ts',m),_))<-runStateT (rmItemsFromImport mod pns) ((ts,unmodified),(-1000,0))+                     return ()+             else return ()++-- ---------------------------------------------------------------------++doDemoting :: GHC.Name -> RefactGhc [GHC.Name]+doDemoting  pn = do++  clearRefactDone -- Only do this action once++  parsed  <- getRefactParsed++  parsed' <- everywhereMStaged' SYB.Parser   (SYB.mkM   demoteInMod+                                             `SYB.extM` demoteInMatch+                                             `SYB.extM` demoteInPat+                                             `SYB.extM` demoteInLet+                                             `SYB.extM` demoteInStmt+                                            ) parsed+  putRefactParsed parsed' emptyAnns+  nm <- getRefactNameMap+  decls <- liftT $ hsDecls parsed+  let demotedDecls'= definingDeclsRdrNames nm [pn] decls True False+      declaredPnsRdr  = nub $ concatMap definedPNsRdr demotedDecls'+      declaredPns = map (rdrName2NamePure nm) declaredPnsRdr+  return declaredPns+    where+       --1. demote from top level+       demoteInMod x@(parsed :: GHC.ParsedSource) = do+         decls <- liftT $ hsDecls parsed+         nm <- getRefactNameMap+         if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False)+           then do+              logm "MoveDef:demoteInMod" -- ++AZ+++              demoted <- doDemoting' parsed pn+              return demoted+           else return x++       --2. The demoted definition is a local decl in a match+       demoteInMatch match@(GHC.L _ (GHC.Match _ _pats _mt (GHC.GRHSs _ _ds))::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do+         -- decls <- liftT $ hsDecls ds+         decls <- liftT $ hsDecls match+         nm <- getRefactNameMap+         if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False)+           then do+              logm "MoveDef:demoteInMatch" -- ++AZ+++              done <- getRefactDone+              match' <- if (not done)+                then doDemoting' match pn+                else return match+              return match'+           else return match++       --3. The demoted definition is a local decl in a pattern binding+       demoteInPat x@(pat@(GHC.L _ (GHC.ValD (GHC.PatBind _p (GHC.GRHSs _grhs _lb) _ _ _)))::GHC.LHsDecl GHC.RdrName) = do+         decls <- liftT $ hsDeclsPatBindD x+         nm <- getRefactNameMap+         if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False)+           then do+              logm "MoveDef:demoteInPat" -- ++AZ+++              done <- getRefactDone+              pat' <- if (not done)+                then doDemoting' pat pn+                else return pat+              return pat'+           else return x+       demoteInPat x = return x++       --4: The demoted definition is a local decl in a Let expression+       demoteInLet x@(letExp@(GHC.L _ (GHC.HsLet _ds _e))::GHC.LHsExpr GHC.RdrName) = do+         decls <- liftT $ hsDecls x+         nm <- getRefactNameMap+         if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False)+           then do+              logm "MoveDef:demoteInLet" -- ++AZ+++              done <- getRefactDone+              letExp' <- if (not done)+                 then doDemoting' letExp pn+                 else return letExp+              return letExp'+           else return x+       demoteInLet x = return x+++       --6.The demoted definition is a local decl in a Let statement.+       -- demoteInStmt (letStmt@(HsLetStmt ds stmts):: (HsStmt (HsExpP) (HsPatP) [HsDeclP]))+       demoteInStmt (letStmt@(GHC.L _ (GHC.LetStmt _binds))::GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do+         decls <- liftT $ hsDecls letStmt+         nm <- getRefactNameMap+         if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False)+           then do+              logm "MoveDef:demoteInStmt" -- ++AZ+++              done <- getRefactDone+              letStmt' <- if (not done)+                then doDemoting' letStmt pn+                else return letStmt+              return letStmt'+           else return letStmt+       demoteInStmt x = return x++++-- |Demote the declaration of 'pn' in the context of 't'.+doDemoting' :: (UsedByRhs t) => t -> GHC.Name -> RefactGhc t+doDemoting' t pn = do+   nm <- getRefactNameMap+   -- origDecls <- liftT $ hsDecls t+   origDecls <- liftT $ hsDeclsGeneric t+   let+       demotedDecls'= definingDeclsRdrNames nm [pn] origDecls True False+       declaredPns = nub $ concatMap (definedNamesRdr nm) demotedDecls'+       pnsUsed = usedByRhsRdr nm t declaredPns+   logm $ "doDemoting':(pn,declaredPns)=" ++ showGhc (pn,declaredPns)+   -- logm $ "doDemoting':t=" ++ (SYB.showData SYB.Renamer 0 t)+   logm $ "doDemoting':(declaredPns,pnsUsed)=" ++ showGhc (declaredPns,pnsUsed)+   r <-  if not pnsUsed -- (usedByRhs t declaredPns)+       then do+              logm $ "doDemoting' no pnsUsed"+              -- dt <- liftT $ hsDecls t+              let dt = origDecls+              let demotedDecls = definingDeclsRdrNames nm [pn] dt True True+                  otherBinds = (deleteFirstsBy (sameBindRdr nm) dt demotedDecls)+                      {- From 'hsDecls t' to 'hsDecls t \\ demotedDecls'.+                         Bug fixed 06/09/2004 to handle direct recursive function.+                       -}+                  xx = map (\b -> (b,uses nm declaredPns [b])) otherBinds+                  useCount = sum $ concatMap snd xx+              logm $ "doDemoting': declaredPns=" ++ (showGhc declaredPns)+              logm $ "doDemoting': uses xx=" ++ (showGhc xx)+              logm $ "doDemoting': uses useCount=" ++ (show useCount)++              case useCount  of+                  0 ->do error "\n Nowhere to demote this function!\n"+                  1 -> --This function is only used by one friend function+                      do+                         logm "MoveDef.doDemoting':target location found" -- ++AZ++++                         let (FN f,_d) = hsFreeAndDeclaredRdr nm demotedDecls+                         (ds,removedDecl,_sigRemoved) <- rmDecl pn False t+                         (t',demotedSigs)             <- rmTypeSigs declaredPns ds++                         logDataWithAnns "MoveDef.doDemoting':after rmTypeSigs:demotedSigs=" demotedSigs++                         logm $ "MoveDef:declaredPns=" ++ (showGhc declaredPns) -- ++AZ++++                         dl <- mapM (flip declaredNamesInTargetPlace ds) declaredPns+                         logm $ "mapM declaredNamesInTargetPlace done"+                         --make sure free variable in 'f' do not clash with variables in 'dl',+                         --otherwise do renaming.+                         let clashedNames=filter (\x-> elem (id x) (map id f)) $ (nub.concat) dl+                         --rename clashed names to new names created automatically,update TOKEN STREAM as well.+                         if clashedNames/=[]+                            then error ("The identifier(s):" ++ showGhc clashedNames +++                                       ", declared in where the definition will be demoted to, will cause name clash/capture"+                                       ++" after demoting, please do renaming first!")+                            else  --duplicate demoted declarations to the right place.+                                 do+                                    duplicateDecls declaredPns removedDecl demotedSigs t'+                                    {-+                                    logm $ "MoveDef: about to duplicateDecls"+                                    dds <- liftT $ hsDecls t'+                                    ds'' <- duplicateDecls declaredPns removedDecl demotedSigs dds+                                    logm $ "MoveDef:duplicateDecls done"+                                    t'' <- liftT $ replaceDecls t' ds''+                                    return t''+                                    -}+                  _ ->error "\nThis function/pattern binding is used by more than one friend bindings\n"++       else error "This function can not be demoted as it is used in current level!\n"++   return r++    where+          ---find how many matches/pattern bindings use  'pn'-------+          uses :: NameMap -> [GHC.Name] -> [GHC.LHsDecl GHC.RdrName] -> [Int]+          uses nm pns t2+               = concatMap used t2+                where++                  used :: GHC.LHsDecl GHC.RdrName -> [Int]+                  used (GHC.L _ (GHC.ValD (GHC.FunBind _n _ (GHC.MG matches _ _ _) _ _ _)))+                     = concatMap (usedInMatch pns) matches++                  used (GHC.L _ (GHC.ValD (GHC.PatBind pat rhs _ _ _)))+                    | (not $ findNamesRdr nm pns pat) && findNamesRdr nm pns rhs+                    = [1::Int]+                  used  _ = []++                  usedInMatch pns' (GHC.L _ (GHC.Match _ pats _ rhs))+                    | (not $ findNamesRdr nm pns' pats) && findNamesRdr nm pns' rhs+                     = [1::Int]+                  usedInMatch _ _ = []+++          duplicateDecls :: (SYB.Data t,SYB.Typeable t)+                         => [GHC.Name] -- ^ function names to be demoted+                         -> GHC.LHsDecl GHC.RdrName   -- ^Bind being demoted+                         -> [GHC.LSig GHC.RdrName]    -- ^Signatures being demoted, if any+                         -> t+                         -> RefactGhc t+          duplicateDecls pns demoted dsig o = do+            logm $ "duplicateDecls:t=" ++ SYB.showData SYB.Parser 0 o+            hasDeclsSybTransform workerHsDecls workerBind o+            where+              workerHsDecls :: forall t. HasDecls t => t -> RefactGhc t+              workerHsDecls t' = do+                dds <- liftT $ hsDecls t'+                ds'' <- duplicateDecls' pns demoted dsig dds+                liftT $ replaceDecls t' ds''++              workerBind :: (GHC.LHsBind GHC.RdrName -> RefactGhc (GHC.LHsBind GHC.RdrName))+              workerBind t'@(GHC.L _ (GHC.PatBind{})) = do+                dds <- liftT $ hsDeclsPatBind t'+                ds'' <- duplicateDecls' pns demoted dsig dds+                liftT $ replaceDeclsPatBind t' ds''+              workerBind x = error $ "MoveDef.duplicateDecls.workerBind:unmatched LHsBind:" ++ showGhc x+++          -- duplicate demotedDecls to the right place (the outer most level where it is used).+          duplicateDecls' :: [GHC.Name] -- ^ function names to be demoted+                          -> GHC.LHsDecl GHC.RdrName   -- ^Bind being demoted+                          -> [GHC.LSig GHC.RdrName]    -- ^Signatures being demoted, if any+                          -> [GHC.LHsDecl GHC.RdrName] -- ^Binds of original top+                                                       -- level entiity,+                                                       -- including src and dst+                          -> RefactGhc [GHC.LHsDecl GHC.RdrName]+          duplicateDecls' pns demoted dsig decls+             = do+                  nm <- getRefactNameMap+                  everywhereMStaged' SYB.Parser (SYB.mkM (dupInMatch nm) -- top-down approach+                                                `SYB.extM` (dupInPat nm)) decls+               where+                 dupInMatch nm (match@(GHC.L _ (GHC.Match _ pats _mt rhs)) :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))+                   | (not $ findNamesRdr nm pns pats) && findNamesRdr nm pns rhs+                   =  do+                        done <- getRefactDone+                        logm $ "duplicateDecls.dupInMatch:value of done=" ++ (show done) -- ++AZ+++                        if done+                          then return match+                          else do+                            logm "duplicateDecls:setting done"  -- ++AZ+++                            setRefactDone+                            match' <- foldParams pns match decls demoted dsig+                            return match'+                 dupInMatch _ x = return x++                 dupInPat nm ((GHC.PatBind pat rhs@(GHC.GRHSs grhs lb) ty fvs ticks) :: GHC.HsBind GHC.RdrName)+                    | (not $ findNamesRdr nm pns pat) && findNamesRdr nm pns rhs+                   = do+                       logm $ "duplicateDecls.dupInPat"+                       let declsToLift = definingDeclsRdrNames' nm pns t+                       lb' <- moveDecl1 lb Nothing pns declsToLift pns []+                       return (GHC.PatBind pat (GHC.GRHSs grhs lb') ty fvs ticks)+                 dupInPat _ x = return x++                 -- demotedDecls = definingDecls pns decls True False+          ---------------------------------------------------------------------++          declaredNamesInTargetPlace :: (SYB.Data t)+                            => GHC.Name -> t+                            -- -> RefactGhc [GHC.Name]+                            -> RefactGhc [GHC.Name]++          declaredNamesInTargetPlace pn' t' = do+             logm $ "declaredNamesInTargetPlace:pn=" ++ (showGhc pn')+             res <- applyTU (stop_tdTU (failTU+                                           `adhocTU` inMatch+                                           `adhocTU` inPat)) t'+             logm $ "declaredNamesInTargetPlace:res=" ++ (showGhc res)+             return res+               where+                 inMatch ((GHC.Match _ _pats _ rhs) :: GHC.Match GHC.Name (GHC.LHsExpr GHC.Name))+                    | findPN pn' rhs = do+                     logm $ "declaredNamesInTargetPlace:inMatch"+                     fds <- hsFDsFromInside rhs+                     return $ snd fds+                 inMatch _ = return mzero++                 inPat ((GHC.PatBind pat rhs _ _ _) :: GHC.HsBind GHC.Name)+                    |findPN pn' rhs = do+                     logm $ "declaredNamesInTargetPlace:inPat"+                     fds <- hsFDsFromInside pat+                     return $ snd fds+                 inPat _=  return mzero++-- ---------------------------------------------------------------------+++{- foldParams:remove parameters in the demotedDecls if possible+   parameters: pn -- the function/pattern name to be demoted in PName format+               match--where the demotedDecls will be demoted to+               demotedDecls -- the declarations to be demoted.+   example:+    module Test where        demote 'sq'       module Test where+    sumSquares x y               ===>          sumSquares x y =(sq 0) + (sq y)+      = sq x 0+ sq x y                               where sq y=x ^ y+    sq x y=x^y+-}+--PROBLEM: TYPE SIGNATURE SHOULD BE CHANGED.+--- TEST THIS FUNCTION!!!+foldParams :: [GHC.Name]             -- ^The (list?) function name being demoted+           -> GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)     -- ^The RHS of the place to receive the demoted decls+           -> [GHC.LHsDecl GHC.RdrName] -- ^Binds of original top level entiity, including src and dst+           -> GHC.LHsDecl GHC.RdrName   -- ^The decls being demoted+           -> [GHC.LSig GHC.RdrName]    -- ^Signatures being demoted, if any+           -> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))+foldParams pns match@(GHC.L l (GHC.Match _mfn _pats _mt rhs)) _decls demotedDecls dsig++     =do+         logm $ "MoveDef.foldParams entered"+         nm <- getRefactNameMap++         let matches = concatMap matchesInDecls [demotedDecls]+             pn = ghead "foldParams" pns    --pns /=[]+         logm $ "MoveDef.foldParams before allParams"+         params <- allParams pn rhs []+         logm $ "foldParams:params=" ++ showGhc params+         if (length.nub.map length) params==1                  -- have same number of param+             && ((length matches)==1)      -- only one 'match' in the demoted declaration+           then do+                   let patsInDemotedDecls=(patsInMatch.(ghead "foldParams")) matches+                       subst = mkSubst nm patsInDemotedDecls params+                       fstSubst = map fst subst+                       sndSubst = map snd subst++                   rhs' <- rmParamsInParent pn sndSubst rhs++                   let ls = map (hsFreeAndDeclaredRdr nm) sndSubst+                   let newNames = ((concatMap (fn . fst) ls)) \\ (fstSubst)+                   --There may be name clashing because of introducing new names.+                   clashedNames <- getClashedNames nm fstSubst newNames (ghead "foldParams" matches)++                   logm $ "MoveDef.foldParams about to foldInDemotedDecls"++                   demotedDecls''' <- foldInDemotedDecls pns clashedNames subst [demotedDecls]+                   logm $ "MoveDef.foldParams foldInDemotedDecls done"++                   let match' = GHC.L l ((GHC.unLoc match) {GHC.m_grhss = rhs' })+                   match'' <- addDecl match' Nothing (demotedDecls''',Nothing)+                   logm $ "MoveDef.foldParams addDecl done 1"+                   return match''+           else  do+                     logm $ "foldParams:no params"+                     let sigs = map wrapSig dsig+                     match' <- addDecl match Nothing (sigs++[demotedDecls],Nothing)+                     logm "MoveDef.foldParams addDecl done 2"+                     return match'++    where++       matchesInDecls :: GHC.LHsDecl GHC.RdrName -> [GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)]+       matchesInDecls (GHC.L _ (GHC.ValD (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _))) = matches+       matchesInDecls _x = []++       patsInMatch (GHC.L _ (GHC.Match _ pats' _ _)) = pats'++       foldInDemotedDecls :: [GHC.Name]  -- ^The (list?) of names to be demoted+                          -> [GHC.Name]  -- ^Any names that clash+                          -> [(GHC.Name, GHC.HsExpr GHC.RdrName)] -- ^Parameter substitutions required+                          -> [GHC.LHsDecl GHC.RdrName] -- ^Binds of original top level entity, including src and dst+                          -> RefactGhc [GHC.LHsDecl GHC.RdrName]+       foldInDemotedDecls  pns' clashedNames subst decls = do+          logm $ "foldInDemotedDecls:(pns',clashedNames,subst)=" ++ showGhc (pns',clashedNames,subst)+          logm $ "foldInDemotedDecls:decls=" ++ SYB.showData SYB.Parser 0 decls+          nm <- getRefactNameMap+          SYB.everywhereMStaged SYB.Parser (SYB.mkM (worker nm) `SYB.extM` (workerBind nm)) decls+          where+          worker nm (match'@(GHC.L _ (GHC.FunBind ln _ (GHC.MG _matches _ _ _) _ _ _)) :: GHC.LHsBind GHC.RdrName)+            = do+                logm $ "foldInDemotedDecls:rdrName2NamePure nm ln=" ++ show (rdrName2NamePure nm ln)+                if isJust (find (== rdrName2NamePure nm ln) pns')+                  then do+                    logm $ "foldInDemotedDecls:found match'"+                    match''  <- foldM (flip autoRenameLocalVar) match' clashedNames+                    match''' <- foldM replaceExpWithUpdToks match'' subst+                    rmParamsInDemotedDecls (map fst subst) match'''+                  else return match'+          worker _ x = return x++          workerBind nm ((GHC.L ll (GHC.ValD d)) :: GHC.LHsDecl GHC.RdrName)+            = do+                (GHC.L _ d') <- worker nm (GHC.L ll d)+                return (GHC.L ll (GHC.ValD d'))+          workerBind _ x = return x++      ------Get all of the paramaters supplied to pn ---------------------------+            {- eg. sumSquares x1 y1 x2 y2 = rt x1 y1 + rt x2 y2+                   rt x y = x+y+              demote 'rt' to 'sumSquares',+              'allParams pn rhs []'  returns [[x1,x2],[y1,y2]]+                where pn is 'rt' and  rhs is 'rt x1 y1 + rt x2 y2'+           -}++       allParams :: GHC.Name -> GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)+                 -> [[GHC.HsExpr GHC.RdrName]]+                 -> RefactGhc [[GHC.HsExpr GHC.RdrName]]+       allParams pn rhs1 initial  -- pn: demoted function/pattern name.+        =do+            nm <- getRefactNameMap+            let p = getOneParam nm pn rhs1+            -- putStrLn (show p)+            logm $ "allParams:p=" ++ showGhc p+            if (nonEmptyList p)+              then do rhs' <- rmOneParam pn rhs1+                      logDataWithAnns "allParams:rhs'=" rhs'+                      allParams pn rhs' (initial++[p])+              else return initial+        where+           getOneParam :: (SYB.Data t) => NameMap -> GHC.Name -> t -> [GHC.HsExpr GHC.RdrName]+           getOneParam nm pn1+              = SYB.everythingStaged SYB.Renamer (++) []+                   ([] `SYB.mkQ`  worker)+              -- =applyTU (stop_tdTU (failTU `adhocTU` worker))+                where+                  worker :: GHC.HsExpr GHC.RdrName -> [GHC.HsExpr GHC.RdrName]+                  worker (GHC.HsApp e1 e2)+                   |(expToNameRdr nm e1 == Just pn1) = [GHC.unLoc e2]+                  worker _ = []++           rmOneParam :: (SYB.Data t) => GHC.Name -> t -> RefactGhc t+           rmOneParam pn1 t+              -- This genuinely needs to be done once only. Damn.+              -- =applyTP (stop_tdTP (failTP `adhocTP` worker))+             = do+                -- _ <- clearRefactDone+                nm <- getRefactNameMap+                everywhereMStaged' SYB.Parser (SYB.mkM (worker nm)) t+                where+                  worker nm (GHC.L _ (GHC.HsApp e1 _e2 )) -- The param being removed is e2+                    |expToNameRdr nm e1 == Just pn1 = return e1+                  worker _ x = return x+{-+              AST output++                 addthree x y z++              becomes++                  (HsApp+                    (L {test/testdata/Demote/WhereIn6.hs:10:17-28}+                     (HsApp+                      (L {test/testdata/Demote/WhereIn6.hs:10:17-26}+                       (HsApp+                        (L {test/testdata/Demote/WhereIn6.hs:10:17-24}+                         (HsVar {Name: WhereIn6.addthree}))+                        (L {test/testdata/Demote/WhereIn6.hs:10:26}+                         (HsVar {Name: x}))))+                      (L {test/testdata/Demote/WhereIn6.hs:10:28}+                       (HsVar {Name: y}))))+                    (L {test/testdata/Demote/WhereIn6.hs:10:30}+                     (HsVar {Name: z})))++-----+                  (HsApp+                     (HsApp+                       (HsApp+                         (HsVar {Name: WhereIn6.addthree}))+                         (HsVar {Name: x}))))+                       (HsVar {Name: y}))))+                     (HsVar {Name: z})))++-----++                  sq p x++               becomes++                  (HsApp+                   (HsApp+                     (HsVar {Name: Demote.WhereIn4.sq}))+                     (HsVar {Name: p}))))+                   (HsVar {Name: x})))++----+                  sq x++               becomes++                  (HsApp+                   (HsVar {Name: sq}))+                   (HsVar {Name: x})))+-}+++       -----------remove parameters in demotedDecls-------------------------------+       rmParamsInDemotedDecls :: [GHC.Name] -> GHC.LHsBind GHC.RdrName+                              -> RefactGhc (GHC.LHsBind GHC.RdrName)+       rmParamsInDemotedDecls ps bind+         -- =applyTP (once_tdTP (failTP `adhocTP` worker))+         = SYB.everywhereMStaged SYB.Parser (SYB.mkM worker) bind+            where worker :: GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName))+                  worker (GHC.Match mfn' pats2 typ rhs1)+                    = do+                         nm <- getRefactNameMap+                         let pats'=filter (\x->not ((patToNameRdr nm x /= Nothing) &&+                                          elem (gfromJust "rmParamsInDemotedDecls" $ patToNameRdr nm x) ps)) pats2+                         return (GHC.Match mfn' pats' typ rhs1)++       ----------remove parameters in the parent functions' rhs-------------------+       rmParamsInParent :: GHC.Name -> [GHC.HsExpr GHC.RdrName]+                        -> GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)+                        -> RefactGhc (GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName))+       rmParamsInParent pn es grhss = do+         nm <- getRefactNameMap+         -- =applyTP (full_buTP (idTP `adhocTP` worker))+         SYB.everywhereMStaged SYB.Renamer (SYB.mkM (worker nm)) grhss+            where worker nm expr@(GHC.L _ (GHC.HsApp e1 e2))+                   | findNamesRdr nm [pn] e1 && (elem (showGhc (GHC.unLoc e2)) (map (showGhc) es))+                      = do+                       liftT $ transferEntryDPT expr e1+                       return e1+                  worker nm (expr@(GHC.L _ (GHC.HsPar e1)))+                    |Just pn==expToNameRdr nm e1+                       = do+                         liftT $ transferEntryDPT expr e1+                         return e1+                  worker _ x =return x+++       getClashedNames :: NameMap -> [GHC.Name] -> [GHC.Name]+                       -> GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)+                       -> RefactGhc [GHC.Name]+       getClashedNames nm oldNames newNames match'+         = do  (_f,DN d) <- hsFDsFromInsideRdr nm match'+               ds' <- mapM (flip (hsVisiblePNsRdr nm) match') oldNames+               -- return clashed names+               return (filter (\x->elem ({- pNtoName -} x) newNames)  --Attention: nub+                                   ( nub (d `union` (nub.concat) ds')))++       ----- make Substitions between formal and actual parameters.-----------------+       mkSubst :: NameMap+               -> [GHC.LPat GHC.RdrName] -> [[GHC.HsExpr GHC.RdrName]]+               -> [(GHC.Name,GHC.HsExpr GHC.RdrName)]+       mkSubst nm pats1 params+           = catMaybes (zipWith (\x y -> if (patToNameRdr nm x/=Nothing) && (length (nub $ map showGhc y)==1)+                                          then Just (gfromJust "mkSubst" $ patToNameRdr nm x,(ghead "mkSubst") y)+                                          else Nothing) pats1 params)+++-- |substitute an old expression by new expression+replaceExpWithUpdToks :: (SYB.Data t)+                      => t -> (GHC.Name, GHC.HsExpr GHC.RdrName)+                      -> RefactGhc t+replaceExpWithUpdToks  decls subst = do+  nm <- getRefactNameMap+  let+    worker (e@(GHC.L l _)::GHC.LHsExpr GHC.RdrName)+      |(expToNameRdr nm e) == Just (fst subst)+          = update e (GHC.L l (snd subst)) e+    worker x=return x++  -- = applyTP (full_buTP (idTP `adhocTP` worker)) decls+  everywhereMStaged' SYB.Parser (SYB.mkM worker) decls+++-- | return True if pn is a local function/pattern name+isLocalFunOrPatName :: SYB.Data t => GHC.Name -> t -> Bool+isLocalFunOrPatName pn scope+ = isLocalPN pn && isFunOrPatName pn scope++-- EOF

@@ -1,6 +1,6 @@-module Language.Haskell.Refact.Refactoring.Renaming(rename) where+module Language.Haskell.Refact.Refactoring.Renaming (rename) where --- import qualified Data.Generics.Schemes as SYB+import qualified Data.Generics.Schemes as SYB import qualified Data.Generics.Aliases as SYB import qualified GHC.SYB.Utils         as SYB @@ -10,12 +10,10 @@  import Control.Monad import Data.List-import Exception -import Language.Haskell.GhcMod+import qualified Language.Haskell.GhcMod as GM (Options(..)) import Language.Haskell.Refact.API---- import Language.Haskell.Refact.Utils.GhcVersionSpecific+import System.Directory  {-This refactoring renames an indentifier to a user-specified name. @@ -46,65 +44,61 @@ -}  -- | Rename the given identifier.-rename :: RefactSettings -> Cradle+rename :: RefactSettings -> GM.Options    -> FilePath -> String -> SimpPos    -> IO [FilePath]-rename settings cradle fileName newName (row,col) =-  runRefacSession settings cradle (comp fileName newName (row,col))+rename settings opts fileName newName (row,col) = do+  absFileName <- canonicalizePath fileName+  runRefacSession settings opts (comp absFileName newName (row,col))  -- | Body of the refactoring 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+    logm $ "Renaming.comp: (fileName,newName,(row,col))=" ++ show (fileName,newName,(row,col))+    parseSourceFileGhc fileName     renamed <- getRefactRenamed     parsed  <- getRefactParsed-    logm $ "comp:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++-    -- logm $ "comp:parsed=" ++ (SYB.showData SYB.Parser 0 parsed) -- ++AZ++      modu <- getModule-    -- let (Just (modName,_)) = getModuleName parsed-    let modName = case (getModuleName parsed) of+    targetModule <- getRefactTargetModule+    let modName = case getModuleName parsed of                     Just (mn,_) -> mn                     Nothing -> GHC.mkModuleName "Main"     let maybePn = locToName (row, col) renamed-    logm $ "Renamed.comp:maybePn=" ++ (showGhc maybePn) -- ++AZ+++    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.1" $ locToRdrName (row, col) parsed-           -- logm $ "Renaming.comp:rdrName'=" ++ (showGhc rdrName')+           logm $ "Renaming:(n,modu)=" ++ showGhc (n,modu)             let (GHC.L _ rdrName) = gfromJust "Renaming.comp.2" $ 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)+           logm $ "Renaming: rdrName=" ++ SYB.showData SYB.Parser 0 rdrName+           logm $ "Renaming: occname rdrName=" ++ show (GHC.occNameString $ GHC.rdrNameOcc rdrName)             unless (nameToString n /= newName) $ error "The new name is same as the old name"            unless (isValidNewName n rdrNameStr newName) $ error $ "Invalid new name:" ++ newName ++ "!"  -           logm $ "Renaming.comp: before GHC.nameModule,n=" ++ (showGhc n)-           -- let defineMod = GHC.moduleName $ GHC.nameModule n+           logm $ "Renaming.comp: before GHC.nameModule,n=" ++ showGhc n             let defineMod = case GHC.nameModule_maybe n of                             Just mn -> GHC.moduleName mn                             Nothing -> modName             -- TODO: why do we have this restriction?-           unless (defineMod == modName ) ( error ("This identifier is defined in module " ++ (show defineMod) +++           unless (defineMod == modName ) ( error ("This identifier is defined in module " ++ GHC.moduleNameString defineMod ++                                          ", please do renaming in that module!"))-           -- logm $ "Renaming.comp:(isMainModule modu,pn)=" ++ (showGhc (isMainModule modu,pn))-           if isMainModule modu && (showGhc pn) == "Main.main"-             then error ("The 'main' function defined in a 'Main' module should not be renamed!")+           logm $ "Renaming.comp:(isMainModule modu,pn)=" ++ (showGhcQual (isMainModule modu,pn))+           if isMainModule modu && showGhcQual pn == "Main.main"+             then error "The 'main' function defined in a 'Main' module should not be renamed!"              else do                logm $ "Renaming.comp: not main module"                newNameGhc <- mkNewGhcName (Just modu) newName                (refactoredMod,nIsExported) <- applyRefac (doRenaming pn rdrNameStr newName newNameGhc modName) RSAlreadyLoaded-               logm $ "Renaming:nIsExported=" ++ (show nIsExported)+               logm $ "Renaming:nIsExported=" ++ show nIsExported                if nIsExported  --no matter whether this pn is used or not.-                   then do clients <- clientModsAndFiles modName-                           logm ("Renaming: clients=" ++ (showGhc clients)) -- ++AZ++ debug+                   then do clients <- clientModsAndFiles targetModule+                           logm ("Renaming: clients=" ++ show clients) -- ++AZ++ debug                            refactoredClients <- mapM (renameInClientMod n newName newNameGhc) clients                            return $ refactoredMod:(concat refactoredClients)                    else  return [refactoredMod]@@ -119,31 +113,18 @@ doRenaming pn@(GHC.L _ oldn) rdrNameStr newNameStr newNameGhc modName = do   logm $ "doRenaming:(pn,rdrNameStr,newNameStr) = " ++ (showGhc (pn,rdrNameStr,newNameStr))   renamed <- getRefactRenamed-  {--  r' <- applyTP (once_buTPGhc (failTP `adhocTP` renameInMod-                                -- `adhocTP` renameInMatch-                                -- `adhocTP` renameInPattern-                                -- `adhocTP` renameInExp-                                -- `adhocTP` renameInAlt-                                -- `adhocTP` renameInStmts-                                )) renamed-                                -}-  -- somewhereMStagedBu SYB.Renamer (SYB.mkM renameInMod-  void $ everywhereMStaged SYB.Renamer (SYB.mkM renameInMod-                                 ) renamed-  logm $ "doRenaming done"+  void $ SYB.everywhereM (SYB.mkM renameInMod+                         ) renamed+  logm "doRenaming done"   nIsExported <- isExported oldn   return nIsExported    where      -- 1. The name is declared in a module(top level name)-     -- renameInMod (mod::HsModuleP)      renameInMod :: GHC.RenamedSource -> RefactGhc GHC.RenamedSource      renameInMod ren-        -- was | isDeclaredIn oldn ren = do         | True = do            logm $ "renameInMod"            renameTopLevelVarName oldn newNameStr newNameGhc modName ren True True-     -- renameInMod _ren = mzero   renameTopLevelVarName :: GHC.Name -> String -> GHC.Name -> GHC.ModuleName -> GHC.RenamedSource@@ -166,7 +147,6 @@      logm $ "renameTopLevelVarName:(scopeClashNames,intersection)=" ++ (showGhc (scopeClashNames,intersect scopeClashNames f'))      logm $ "renameTopLevelVarName:(oldPN,modName)=" ++ (showGhc (oldPN,modName))      if (nonEmptyList $ intersect scopeClashNames f')-     -- if elem newNameStr f        then error ("The new name will cause ambiguous occurrence problem,"                    ++" please select another new name or qualify the use of ' "                    ++ newName ++ "' before renaming!\n") -- Another implementation option is to add the qualifier@@ -181,13 +161,11 @@                                   logm $ "renameTopLevelVarName:basic tests done" -                                 -- isInScopeUnqual <- isInScopeAndUnqualifiedGhc newName Nothing                                  isInScopeUnqual <- isInScopeAndUnqualifiedGhc newName (Just newNameGhc)                                  logm $ "renameTopLevelVarName:after isInScopeUnqual"                                  logm $ "renameTopLevelVarName:oldPN=" ++ showGhc oldPN                                  ds <- hsVisibleNames oldPN renamed                                  logm $ "renameTopLevelVarName:ds computed=" ++ (show ds)-                                 -- '\\[pNtoName oldPN]' handles the case in which the new name is same as the old name                                     if existChecking && elem newName ((nub (ds `union` f)) \\[nameToString oldPN])                                    then error ("Name '"++newName++"'  already existed, or rename '"                                                 ++nameToString oldPN++ "' to '"++newName++@@ -195,72 +173,88 @@                                    else if exportChecking && isInScopeUnqual -- isInScopeAndUnqualifiedGhc newName Nothing                                           then do                                                logm $ "renameTopLevelVarName start..:should have qualified"-                                               void $ renamePN oldPN newNameGhc True True renamed+                                               parsed <- getRefactParsed+                                               parsed' <- renamePN' oldPN newNameGhc True parsed+                                               putRefactParsed parsed' mempty                                                logm $ "renameTopLevelVarName done:should have qualified"-                                               -- drawTokenTreeDetailed "should be qualified" -- ++AZ++ debug                                                r' <- getRefactRenamed                                                return r'                                           else do                                                logm $ "renameTopLevelVarName start.."-                                               void $ renamePN oldPN newNameGhc True False renamed+                                               parsed <- getRefactParsed+                                               parsed' <- renamePN' oldPN newNameGhc False parsed+                                               putRefactParsed parsed' mempty                                                logm $ "renameTopLevelVarName done"                                                r' <- getRefactRenamed                                                return r'   renameInClientMod :: GHC.Name -> String -> GHC.Name -> TargetModule- -> RefactGhc [ApplyRefacResult]-renameInClientMod oldPN newName newNameGhc targetModule@(_,modSummary) = do-      logm $ "renameInClientMod:(oldPN,newNameGhc,modSummary)=" ++ (showGhc (oldPN,newNameGhc,targetModule)) -- ++AZ++-      void $ activateModule targetModule-      {- ++AZ++ debug stuff -}-      names <- ghandle handler (GHC.parseName $ nameToString oldPN)-      nameInfo <- mapM GHC.lookupName names-      logm $ "renameInClientMod: nameInfo=" ++ (showGhc nameInfo)-      {- ++AZ++ debug stuff end -}+                  -> RefactGhc [ApplyRefacResult]+renameInClientMod oldPN newName newNameGhc targetModule = do+      logm $ "renameInClientMod:(oldPN,newNameGhc,targetModule)=" ++ (showGhc (oldPN,newNameGhc,targetModule)) -- ++AZ+++      logm $ "renameInClientMod:(newNameGhc module)=" ++ (showGhc (GHC.nameModule newNameGhc)) -- ++AZ+++      getTargetGhc targetModule        renamed <- getRefactRenamed-      let modName = GHC.moduleName $ GHC.ms_mod modSummary-      -- causeNameClashInExports oldPN newName mod exps-      -- logm $ "renameInClientMod:causeNameClashInExports oldPN modName renamed=" ++ (show $ causeNameClashInExports oldPN modName renamed)+      modName <- getRefactModuleName +      -- We need to find the old name in the module, and get it as a+      -- GHC.Name to know what to look for in the call to renamePN', as it+      -- checks the GHC.nameUnique value.+      -- gnames <- GHC.getNamesInScope+      -- let clientModule = GHC.nameModule oldPN+      -- let clientInscopes = filter (\n -> clientModule == GHC.nameModule n) gnames+      -- logm $ "renameInClientMod:(clientInscopes)=" ++ showGhcQual (clientInscopes)+      -- let newNames = filter (\n -> showGhcQual n == showGhcQual oldPN) clientInscopes+      newNames <- equivalentNameInNewMod oldPN+      logm $ "renameInClientMod:(newNames)=" ++ showGhcQual (newNames)++      -- newNames       <- inScopeNames (showGhcQual oldPN)+      -- newNamesUnqual <- inScopeNames (showGhc     oldPN)+      -- logm $ "renameInClientMod:(newNamesUnqual,oldPN)=" ++ showGhcQual (newNamesUnqual,oldPN)+      -- logm $ "renameInClientMod:(newNames,oldPN)=" ++ showGhcQual (newNames,oldPN)+      -- logm $ "renameInClientMod:(uniques:newNames,oldPN)=" ++ showGhcQual (map GHC.nameUnique newNames,GHC.nameUnique oldPN)+      let oldNameGhc = case newNames of+            [n] -> n+            ns  -> error $ "HaRe:renameInClientMod:could not find name to replace,got:" ++ showGhcQual ns+       -- There are two different tests we need to do here       -- 1. Does the new name clash with some existing name in the       --    client mod, in which case it must be qualified       -- 2. Is the new name module imported qualified, and so needs to       --    be qualified in the replacement, according to the import-      isInScopeUnqual <- isInScopeAndUnqualifiedGhc (nameToString oldPN) Nothing-      isInScopeUnqualNew <- isInScopeAndUnqualifiedGhc newName Nothing+      isInScopeUnqual    <- isInScopeAndUnqualifiedGhc (nameToString oldPN) Nothing+      isInScopeUnqualNew <- isInScopeAndUnqualifiedGhc newName              Nothing       logm $ "renameInClientMod: (isInScopeAndUnqual,isInScopeUnqualNew)=" ++ (show (isInScopeUnqual,isInScopeUnqualNew)) -- ++AZ++-      -- if  qualifier == []  --this name is not imported, but it maybe used in the import list-      -- if isInScopeUnqual-      if isInScopeUnqualNew+      if isInScopeUnqualNew -- ++AZ++: should this be negated?        then-        -- do (mod', ((ts',m),f))<-runStateT (renamePN oldPN Nothing newName True mod) ((ts,unmodified), fileName)         do-           (refactoredMod,_) <- applyRefac (refactRenameSimple oldPN newName newNameGhc True) RSAlreadyLoaded+           -- (refactoredMod,_) <- applyRefac (refactRenameSimple oldPN newName newNameGhc True) RSAlreadyLoaded+           (refactoredMod,_) <- applyRefac (refactRenameSimple oldNameGhc newName newNameGhc True) RSAlreadyLoaded            return [refactoredMod]        else-        do if causeNameClashInExports oldPN newNameGhc modName renamed+        do+           if causeNameClashInExports oldPN newNameGhc modName renamed              then error $"The new name will cause conflicting exports in module "++ show newName ++ ", please select another name!"              else do-               (refactoredMod,_) <- applyRefac (refactRenameComplex oldPN newName newNameGhc) RSAlreadyLoaded+               -- (refactoredMod,_) <- applyRefac (refactRenameComplex oldPN newName newNameGhc) RSAlreadyLoaded+               (refactoredMod,_) <- applyRefac (refactRenameComplex oldNameGhc newName newNameGhc) RSAlreadyLoaded                -- TODO: implement rest of this                return [refactoredMod]   where-     handler:: (GHC.GhcMonad m) => SomeException -> m [GHC.Name]-     handler _ = return []-      refactRenameSimple :: GHC.Name -> String -> GHC.Name -> Bool -> RefactGhc ()      refactRenameSimple old newStr new useQual = do+       logm $ "refactRenameSimple:(old,newStr,new,useQual)=" ++ showGhc (old,newStr,new,useQual)        qualifyTopLevelVar newStr-       renamed <- getRefactRenamed-       logm $ "renameInClientMod.refactRename:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++-       void $ renamePN old new True useQual renamed+       parsed <- getRefactParsed+       parsed' <- renamePN' old new useQual parsed+       putRefactParsed parsed' mempty        return ()       refactRenameComplex :: GHC.Name -> String -> GHC.Name -> RefactGhc ()      refactRenameComplex old new newGhc = do+       logm $ "refactRenameComplex:(old,new,newGhc)=" ++ showGhc (old,new,newGhc)        qualifyTopLevelVar new        worker old new newGhc @@ -268,20 +262,21 @@      qualifyTopLevelVar new = do        toQualify <- inScopeNames new        logm $ "renameInClientMod.qualifyTopLevelVar:new:toQualify=" ++ (show new) ++ ":" ++ (showGhc toQualify)-       -- renamed <- getRefactRenamed-       -- renamePN new new True True renamed        mapM_ qualifyToplevelName toQualify        return ()       worker :: GHC.Name -> String -> GHC.Name -> RefactGhc ()      worker oldPN' newName' newNameGhc' = do-       logm $ "renameInClientMod.worker"+       logm $ "renameInClientMod.worker:(oldPN',newName',newNameGhc')=" ++ showGhc (oldPN',newName',newNameGhc')        renamed <- getRefactRenamed+       parsed <- getRefactParsed        isInScopeUnqualNew <- isInScopeAndUnqualifiedGhc newName' Nothing        vs <- hsVisibleNames oldPN' renamed   --Does this check names other than variable names?-       if elem newName' ((nub vs) \\ [nameToString oldPN'])  || isInScopeUnqualNew-         then void $ renamePN oldPN' newNameGhc' True True renamed --rename to qualified Name-         else void $ renamePN oldPN' newNameGhc' True False renamed -- do not qualify+       logm $ "renameInClientMod.worker:(vs,oldPN',isInScopeUnqualNew)=" ++ showGhc (vs,oldPN',isInScopeUnqualNew)+       parsed' <- if elem newName' ((nub vs) \\ [nameToString oldPN'])  || isInScopeUnqualNew+         then renamePN' oldPN' newNameGhc' True  parsed --rename to qualified Name+         else renamePN' oldPN' newNameGhc' False parsed -- do not qualify+       putRefactParsed parsed' mempty        return ()  @@ -309,22 +304,10 @@                     (isConId newName)                     "Invalid type constructor/class name!" -   -- classOk = if isClassName oldName && isConId newName-   --            then True-   --            else error "Invalid class name!"-    dataConOk = doTest (GHC.isDataConName oldName)                       (isConId newName)                       "Invalid data constructor name!" -   -- fieldOk = doTest (isFieldName oldName)-   --                  (isVarId newName)-   --                  "Invalid field name!"--   -- instanceOk = doTest (isInstanceName oldName)-   --                     (isVarId newName)-   --                     "Invalid class instance name!"-    tyVarOk = doTest (GHC.isTyVarName oldName)                     (isVarId newName)                     "Invalid type variable name!"@@ -346,5 +329,5 @@    res = tyconOk && dataConOk {- && fieldOk && instanceOk -} &&          tyVarOk && matchNamesOk -   -- res = error $ "isValidNewName:(tyconOk,dataConOk`,fieldOk,instanceOk,tyVarOk,matchNamesOk)=" ++ (show (tyconOk,dataConOk,fieldOk,instanceOk,tyVarOk,matchNamesOk))+-- EOF 

@@ -0,0 +1,23 @@+module Language.Haskell.Refact.Refactoring.RoundTrip(roundTrip) where++import qualified Language.Haskell.GhcMod as GM (Options(..))+import Language.Haskell.Refact.API++import System.Directory++-- ---------------------------------------------------------------------++-- | Roundtrip the source code, to check that the infrastructure is solid+roundTrip :: RefactSettings -> GM.Options -> FilePath -> IO [FilePath]+roundTrip settings opts fileName = do+  absFileName <- canonicalizePath fileName+  runRefacSession settings opts (comp absFileName)++comp :: FilePath -> RefactGhc [ApplyRefacResult]+comp fileName = do+  parseSourceFileGhc fileName+  (r,_) <- applyRefac (setRefactStreamModified RefacModified) RSAlreadyLoaded+  return [r]++-- EOF+

@@ -0,0 +1,56 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+module Language.Haskell.Refact.Refactoring.Simple(removeBracket) where++import qualified Data.Generics         as SYB++import qualified GHC           as GHC++import qualified Language.Haskell.GhcMod as GM (Options(..))+import Language.Haskell.Refact.API++-- To be moved into HaRe API+import Language.Haskell.GHC.ExactPrint.Transform+import Language.Haskell.GHC.ExactPrint.Types++import Data.Maybe+import System.Directory++-- import Debug.Trace++-- ---------------------------------------------------------------------++-- | Convert an if expression to a case expression+removeBracket :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> SimpPos -> IO [FilePath]+removeBracket settings opts fileName beginPos endPos = do+  absFileName <- canonicalizePath fileName+  let applied = (:[]) . fst <$> applyRefac+                  (removeBracketTransform absFileName beginPos endPos)+                  (RSFile absFileName)+  runRefacSession settings opts applied++type HsExpr a = GHC.Located (GHC.HsExpr a)+pattern HsPar l s = GHC.L l (GHC.HsPar s)++removeBracketTransform  :: FilePath -> SimpPos -> SimpPos -> RefactGhc ()+removeBracketTransform fileName beginPos endPos = do+       parseSourceFileGhc fileName+       parsed <- getRefactParsed+       let expr :: GHC.Located (GHC.HsExpr GHC.RdrName)+           expr = fromJust $ locToExp beginPos endPos parsed+           removePar :: HsExpr GHC.RdrName -> RefactGhc (HsExpr GHC.RdrName)+           removePar e@(HsPar _ s)+            | sameOccurrence e expr = do+              startAnns <- liftT $ getAnnsT+              let oldkey = mkAnnKey e+                  newkey = mkAnnKey s+                  newanns = fromMaybe startAnns $ replace oldkey newkey startAnns+              setRefactAnns newanns+              return s+           removePar e = return e+       p2 <- SYB.everywhereM (SYB.mkM removePar) parsed+       (liftT getAnnsT) >>= putRefactParsed p2+       logm $ "logm: after refactor\n" ++ showGhc p2++-- EOF+

@@ -7,22 +7,30 @@ import qualified Name                  as GHC import qualified GHC -import Language.Haskell.GhcMod+import qualified Language.Haskell.GhcMod as GM (Options(..)) import Language.Haskell.Refact.API +import Data.Generics.Schemes++import Language.Haskell.GHC.ExactPrint.Types+import System.Directory+++ -- TODO: replace args with specific parameters-swapArgs :: RefactSettings -> Cradle -> [String] -> IO [FilePath]-swapArgs settings cradle args+swapArgs :: RefactSettings -> GM.Options -> [String] -> IO [FilePath]+swapArgs settings opts args   = do let fileName = args!!0            row = (read (args!!1)::Int)            col = (read (args!!2)::Int)-       runRefacSession settings cradle (comp fileName (row,col))+       absFileName <- canonicalizePath fileName+       runRefacSession settings opts (comp absFileName (row,col))   comp :: String -> SimpPos      -> RefactGhc [ApplyRefacResult] comp fileName (row, col) = do-       getModuleGhc fileName+       parseSourceFileGhc fileName        renamed <- getRefactRenamed         let name = locToName (row, col) renamed@@ -47,64 +55,76 @@        -- putStrLn "Completd"  -doSwap ::- (GHC.Located GHC.Name) -> RefactGhc () -- m GHC.ParsedSource-doSwap name = do-    -- inscopes <- getRefactInscopes-    renamed  <- getRefactRenamed-    -- parsed   <- getRefactParsed-    reallyDoSwap name renamed--reallyDoSwap :: (GHC.Located GHC.Name) -> GHC.RenamedSource -> RefactGhc ()-reallyDoSwap (GHC.L _s n1) renamed = do-    renamed' <- everywhereMStaged SYB.Renamer (SYB.mkM inMod `SYB.extM` inExp `SYB.extM` inType) renamed -- this needs to be bottom up +++ CMB +++-    putRefactRenamed renamed'+doSwap :: (GHC.Located GHC.Name) -> RefactGhc ()+doSwap (GHC.L _s n1) = do+    parsed <- getRefactParsed+    logm $ "doSwap:parsed=" ++ SYB.showData SYB.Parser 0 parsed+    nm <- getRefactNameMap+    parsed' <- everywhereM (SYB.mkM (inMod nm)+                           `SYB.extM` (inExp nm)+                           `SYB.extM` (inType nm)+                           `SYB.extM` (inTypeDecl nm)+                           ) parsed+    -- this needs to be bottom up +++ CMB ++++    putRefactParsed parsed' emptyAnns     return ()      where          -- 1. The definition is at top level...-         inMod (_func@(GHC.FunBind (GHC.L x n2) infixity (GHC.MatchGroup matches p) a locals tick)::(GHC.HsBindLR GHC.Name GHC.Name ))-            | GHC.nameUnique n1 == GHC.nameUnique n2-                    = do logm ("inMatch>" ++ SYB.showData SYB.Parser 0 (GHC.L x n2) ++ "<")+         inMod nm ((GHC.FunBind ln2 infixity (GHC.MG matches p m1 m2) a locals tick)::GHC.HsBind GHC.RdrName)+            | GHC.nameUnique n1 == GHC.nameUnique (rdrName2NamePure nm ln2)+                    = do logm ("inMatch>" ++ SYB.showData SYB.Parser 0 ln2 ++ "<")                          newMatches <- updateMatches matches-                         return (GHC.FunBind (GHC.L x n2) infixity (GHC.MatchGroup newMatches p) a locals tick)-         inMod func = return func+                         return (GHC.FunBind ln2 infixity (GHC.MG newMatches p m1 m2) a locals tick)+         inMod _ func = return func           -- 2. All call sites of the function...-         inExp expr@((GHC.L _x (GHC.HsApp (GHC.L _y (GHC.HsApp e e1)) e2))::GHC.Located (GHC.HsExpr GHC.Name))-            | GHC.nameUnique (expToName e) == GHC.nameUnique n1+         inExp nm expr@((GHC.L _x (GHC.HsApp (GHC.L _y (GHC.HsApp e e1)) e2))::GHC.LHsExpr GHC.RdrName)+            | cond                    =  update e2 e1 =<< update e1 e2 expr-         inExp e = return e+            where+              cond = case (expToNameRdr nm e) of+                Nothing -> False+                Just n2 -> GHC.nameUnique n2 == GHC.nameUnique n1+         inExp _ e = return e           -- 3. Type signature...-         inType (GHC.L x (GHC.TypeSig [GHC.L x2 name] types)::GHC.LSig GHC.Name)-           | GHC.nameUnique name == GHC.nameUnique n1-                = do let (t1:t2:ts) = tyFunToList types+         inType nm (GHC.L x (GHC.TypeSig [lname] types pns)::GHC.LSig GHC.RdrName)+           | GHC.nameUnique (rdrName2NamePure nm lname) == GHC.nameUnique n1+                = do+                     logm $ "doSwap.inType"+                     let (t1:t2:ts) = tyFunToList types                      t1' <- update t1 t2 t1                      t2' <- update t2 t1 t2-                     return (GHC.L x (GHC.TypeSig [GHC.L x2 name] (tyListToFun (t1':t2':ts))))+                     return (GHC.L x (GHC.TypeSig [lname] (tyListToFun (t1':t2':ts)) pns)) -         inType (GHC.L _x (GHC.TypeSig (n:ns) _types)::GHC.LSig GHC.Name)-           | GHC.nameUnique n1 `elem` (map (\(GHC.L _ n') -> GHC.nameUnique n') (n:ns))-            = error "Error in swapping arguments in type signature: signauture bound to muliple entities!"+         inType nm (GHC.L _x (GHC.TypeSig (n:ns) _types _)::GHC.LSig GHC.RdrName)+           | GHC.nameUnique n1 `elem` (map (\n' -> GHC.nameUnique (rdrName2NamePure nm n')) (n:ns))+            = error "Error in swapping arguments in type signature: signature bound to muliple entities!" -         inType ty = return ty+         inType _ ty = return ty -         tyFunToList (GHC.L _ (GHC.HsForAllTy _ _ _ (GHC.L _ (GHC.HsFunTy t1 t2)))) = t1 : (tyFunToList t2)+         inTypeDecl nm (GHC.L l (GHC.SigD s)) = do+           (GHC.L _ s') <- inType nm (GHC.L l s)+           return (GHC.L l (GHC.SigD s'))+         inTypeDecl _ x = return x++         tyFunToList (GHC.L _ (GHC.HsForAllTy _ _ _ _ (GHC.L _ (GHC.HsFunTy t1 t2)))) = t1 : (tyFunToList t2)          tyFunToList (GHC.L _ (GHC.HsFunTy t1 t2)) = t1 : (tyFunToList t2)          tyFunToList t = [t] +         tyListToFun []   = error "SwapArgs.tyListToFun" -- Keep the exhaustiveness checker happy          tyListToFun [t1] = t1          tyListToFun (t1:ts) = GHC.noLoc (GHC.HsFunTy t1 (tyListToFun ts))           updateMatches [] = return []-         updateMatches ((GHC.L x (GHC.Match pats nothing rhs)::GHC.Located (GHC.Match GHC.Name)):matches)+         updateMatches ((GHC.L x (GHC.Match mfn pats nothing rhs)::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)):matches)            = case pats of                (p1:p2:ps) -> do p1' <- update p1 p2 p1                                 p2' <- update p2 p1 p2                                 matches' <- updateMatches matches-                                return ((GHC.L x (GHC.Match (p1':p2':ps) nothing rhs)):matches')-               [p] -> return [GHC.L x (GHC.Match [p] nothing rhs)]-               []  -> return [GHC.L x (GHC.Match [] nothing rhs)]+                                return ((GHC.L x (GHC.Match mfn (p1':p2':ps) nothing rhs)):matches')+               [p] -> return [GHC.L x (GHC.Match mfn [p] nothing rhs)]+               []  -> return [GHC.L x (GHC.Match mfn [] nothing rhs)]