{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} 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 -- TODO: replace args with specific parameters 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 parsed <- getRefactParsed nm <- getRefactNameMap let name = locToNameRdrPure nm (row, col) parsed case name of -- (Just pn) -> do refactoredMod@(_, (_t, s)) <- applyRefac (doSwap pnt pn) (Just modInfo) fileName (Just pn) -> do (refactoredMod,_) <- applyRefac (doSwap pn) (RSFile fileName) return [refactoredMod] Nothing -> error "Incorrect identifier selected!" --if isFunPNT pnt mod -- Add this back in ++ CMB +++ -- then do -- rs <-if isExported pnt exps -- then applyRefacToClientMods (doSwap pnt) fileName -- else return [] -- writeRefactoredFiles False (r:rs) -- else error "\nInvalid cursor position!" -- putStrLn (showToks t) -- writeRefactoredFiles False [refactoredMod] -- putStrLn ("here" ++ (SYB.showData SYB.Parser 0 mod)) -- $ show [fileName, beginPos, endPos] -- putStrLn "Completd" doSwap :: GHC.Name -> RefactGhc () doSwap 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... #if __GLASGOW_HASKELL__ <= 710 inMod nm ((GHC.FunBind ln2 infixity (GHC.MG matches p m1 m2) a locals tick)::GHC.HsBind GHC.RdrName) #else inMod nm ((GHC.FunBind ln2 (GHC.MG (GHC.L lm matches) p m1 m2) a locals tick)::GHC.HsBind GHC.RdrName) #endif | GHC.nameUnique n1 == GHC.nameUnique (rdrName2NamePure nm ln2) = do logm ("inMatch>" ++ SYB.showData SYB.Parser 0 ln2 ++ "<") newMatches <- updateMatches matches #if __GLASGOW_HASKELL__ <= 710 return (GHC.FunBind ln2 infixity (GHC.MG newMatches p m1 m2) a locals tick) #else return (GHC.FunBind ln2 (GHC.MG (GHC.L lm newMatches) p m1 m2) a locals tick) #endif inMod _ func = return func -- 2. All call sites of the function... inExp nm ((GHC.L l (GHC.HsApp (GHC.L e0 (GHC.HsApp e e1)) e2))::GHC.LHsExpr GHC.RdrName) | cond -- = update e2 e1 =<< update e1 e2 expr = do -- expr1 <- update e1 e2 expr -- expr2 <- update e2 e1 expr1 -- return expr2 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 -- 3. Type signature... #if __GLASGOW_HASKELL__ <= 710 inType nm (GHC.L x (GHC.TypeSig [lname] types pns)::GHC.LSig GHC.RdrName) #else inType nm (GHC.L x (GHC.TypeSig [lname] (GHC.HsIB ivs (GHC.HsWC wcs mwc types)))::GHC.LSig GHC.RdrName) #endif | 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 let t1' = t2 let t2' = t1 #if __GLASGOW_HASKELL__ <= 710 return (GHC.L x (GHC.TypeSig [lname] (tyListToFun (t1':t2':ts)) pns)) #else return (GHC.L x (GHC.TypeSig [lname] (GHC.HsIB ivs (GHC.HsWC wcs mwc (tyListToFun (t1':t2':ts)))))) #endif #if __GLASGOW_HASKELL__ <= 710 inType nm (GHC.L _x (GHC.TypeSig (n:ns) _types _)::GHC.LSig GHC.RdrName) #else inType nm (GHC.L _x (GHC.TypeSig (n:ns) _types )::GHC.LSig GHC.RdrName) #endif | 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 #if __GLASGOW_HASKELL__ <= 710 tyFunToList (GHC.L _ (GHC.HsForAllTy _ _ _ _ (GHC.L _ (GHC.HsFunTy t1 t2)))) = t1 : (tyFunToList t2) #else tyFunToList (GHC.L _ (GHC.HsForAllTy _ (GHC.L _ (GHC.HsFunTy t1 t2)))) = t1 : (tyFunToList t2) #endif 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 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 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)]