HaRe-0.7.0.0: src/Language/Haskell/Refact/SwapArgs.hs
{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.Refact.SwapArgs (swapArgs) where
import qualified Data.Generics.Schemes as SYB
import qualified Data.Generics.Aliases as SYB
import qualified GHC.SYB.Utils as SYB
import qualified FastString as GHC
import qualified Name as GHC
import qualified GHC
import qualified DynFlags as GHC
import qualified Outputable as GHC
import qualified MonadUtils as GHC
import qualified RdrName as GHC
import qualified OccName as GHC
import GHC.Paths ( libdir )
import Control.Monad
import Control.Monad.State
import Data.Data
import Data.Maybe
import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal
import Language.Haskell.Refact.Utils
import Language.Haskell.Refact.Utils.GhcUtils
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 Debug.Trace
-- TODO: replace args with specific parameters
swapArgs :: RefactSettings -> Cradle -> [String] -> IO [FilePath]
swapArgs settings cradle args
= do let fileName = args!!0
row = (read (args!!1)::Int)
col = (read (args!!2)::Int)
runRefacSession settings cradle (comp fileName (row,col))
comp :: String -> SimpPos
-> RefactGhc [ApplyRefacResult]
comp fileName (row, col) = do
-- loadModuleGraphGhc maybeMainFile
-- modInfo@(_t, _tokList) <- getModuleGhc fileName
getModuleGhc fileName
renamed <- getRefactRenamed
-- parsed <- getRefactParsed
-- modInfo@((_, renamed, mod), toks) <- parseSourceFileGhc fileName
-- putStrLn $ showParsedModule mod
-- let pnt = locToPNT fileName (row, col) mod
let name = locToName (GHC.mkFastString fileName) (row, col) renamed
-- error (SYB.showData SYB.Parser 0 name)
case name of
-- (Just pn) -> do refactoredMod@(_, (_t, s)) <- applyRefac (doSwap pnt pn) (Just modInfo) fileName
(Just pn) -> do
-- let pnt = locToPNT (GHC.mkFastString fileName) (row, col) renamed
-- let pnt = gfromJust "SwapArgs.comp" $ locToRdrName (GHC.mkFastString fileName) (row, col) renamed
(refactoredMod@(_, (_t, _s)),_) <- 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.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'
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) ++ "<")
newMatches <- updateMatches matches
return (GHC.FunBind (GHC.L x n2) infixity (GHC.MatchGroup newMatches p) a locals tick)
inMod func = return func
-- 2. All call sites of the function...
inExp exp@((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
= update e2 e1 =<< update e1 e2 exp
inExp e = return e
-- 3. Type signature...
inType ty@(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
t1' <- update t1 t2 t1
t2' <- update t2 t1 t2
return (GHC.L x (GHC.TypeSig [GHC.L x2 name] (tyListToFun (t1':t2':ts))))
inType ty@(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 ty = return ty
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 [t1] = t1
tyListToFun (t1:ts) = GHC.noLoc (GHC.HsFunTy t1 (tyListToFun ts))
updateMatches [] = return []
updateMatches (i@(GHC.L x m@(GHC.Match pats nothing rhs)::GHC.Located (GHC.Match GHC.Name)):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')
{- inMatch i@(GHC.L x m@(GHC.Match (p1:p2:ps) nothing rhs)::GHC.Located (GHC.Match GHC.RdrName) )
-- = error (SYB.showData SYB.Parser 0 pnt)
| GHC.srcSpanStart s == GHC.srcSpanStart x
= do logm ("inMatch>" ++ SYB.showData SYB.Parser 0 (p1:p2:ps) ++ "<")
p1' <- update p1 p2 p1 --pats
p2' <- update p2 p1 p2
return (GHC.L x (GHC.Match (p1':p2':ps) nothing rhs))
inMatch i = return i
inExp exp@((GHC.L x (GHC.HsApp (GHC.L y (GHC.HsApp e e1)) e2))::GHC.Located (GHC.HsExpr GHC.RdrName))
{- | (fromJust $ expToName e) == (GHC.L s (GHC.nameRdrName n))-} -- = error (SYB.showData SYB.Parser 0 (GHC.L s (GHC.nameRdrName n))) -- update e2 e1 =<< update e1 e2 exp
-- inExp e = return e -}
-- In the call-site.
{- inExp exp@((Exp (HsApp (Exp (HsApp e e1)) e2))::HsExpP)
| expToPNT e == pnt
= update e2 e1 =<< update e1 e2 exp
inExp e = return e -}
-- pats nothing rhss ds)
-- expToPNT x = undefined
-- prettyprint :: (GHC.Outputable a) => a -> String
-- prettyprint x = GHC.showSDoc $ GHC.ppr x