module Language.Haskell.Refact.Refactoring.SwapArgs (swapArgs) where
import qualified Data.Generics.Aliases as SYB
import qualified GHC.SYB.Utils as SYB
import qualified Name as GHC
import qualified GHC
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
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)
absFileName <- canonicalizePath fileName
runRefacSession settings opts (comp absFileName (row,col))
comp :: String -> SimpPos
-> RefactGhc [ApplyRefacResult]
comp fileName (row, col) = do
parseSourceFileGhc fileName
renamed <- getRefactRenamed
let name = locToName (row, col) renamed
case name of
(Just pn) -> do
(refactoredMod,_) <- applyRefac (doSwap pn) (RSFile fileName)
return [refactoredMod]
Nothing -> error "Incorrect identifier selected!"
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
putRefactParsed parsed' emptyAnns
return ()
where
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 ln2 infixity (GHC.MG newMatches p m1 m2) a locals tick)
inMod _ func = return func
inExp nm ((GHC.L l (GHC.HsApp (GHC.L e0 (GHC.HsApp e e1)) e2))::GHC.LHsExpr GHC.RdrName)
| cond
= do
return (GHC.L l (GHC.HsApp (GHC.L e0 (GHC.HsApp e e2)) e1))
where
cond = case (expToNameRdr nm e) of
Nothing -> False
Just n2 -> GHC.nameUnique n2 == GHC.nameUnique n1
inExp _ e = return e
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
let t1' = t2
let t2' = t1
return (GHC.L x (GHC.TypeSig [lname] (tyListToFun (t1':t2':ts)) pns))
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
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"
tyListToFun [t1] = t1
tyListToFun (t1:ts) = GHC.noLoc (GHC.HsFunTy t1 (tyListToFun ts))
updateMatches [] = return []
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
let p1' = p2
let p2' = p1
matches' <- updateMatches matches
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)]