HaRe-0.7.1.3: 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 Language.Haskell.GhcMod
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.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 (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,_) <- 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 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
= update e2 e1 =<< update e1 e2 expr
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
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 (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 ((GHC.L x (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')
[p] -> return [GHC.L x (GHC.Match [p] nothing rhs)]
[] -> return [GHC.L x (GHC.Match [] nothing rhs)]
{- 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