module Language.Haskell.Refact.Refactoring.Case(ifToCase) where
import qualified Data.Generics as SYB
import qualified GHC.SYB.Utils as SYB
import qualified GHC as GHC
import Control.Monad
import Control.Monad.IO.Class
import Language.Haskell.GhcMod
import Language.Haskell.Refact.API
ifToCase :: RefactSettings -> Cradle -> FilePath -> SimpPos -> SimpPos -> IO [FilePath]
ifToCase settings cradle fileName beginPos endPos =
runRefacSession settings cradle (comp fileName 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)
let expr = locToExp beginPos endPos renamed
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!"
doIfToCaseInternal ::
GHC.Located (GHC.HsExpr GHC.Name)
-> RefactGhc ()
doIfToCaseInternal expr = do
rs <- getRefactRenamed
reallyDoIfToCase expr rs
reallyDoIfToCase ::
GHC.Located (GHC.HsExpr GHC.Name)
-> GHC.RenamedSource
-> RefactGhc ()
reallyDoIfToCase expr rs = do
void $ everywhereMStaged SYB.Renamer (SYB.mkM inExp) rs
showLinesDebug "after refactoring"
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 _)))
| sameOccurrence expr exp1
= do
newExp <- ifToCaseTransform exp1
let (GHC.RealSrcLoc rl) = GHC.srcSpanStart l
caseTok <- liftIO $ tokenise rl 0 False "case"
condToks <- getToksForSpan l1
ofTok <- liftIO $ tokenise (realSrcLocFromTok (glast "reallyDoIfToCase" condToks)) 1 True "of"
trueToks <- liftIO $ basicTokenise "True ->"
falseToks <- liftIO $ 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
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:t4=[" ++ (GHC.showRichTokenStream t4) ++ "]"
logm $ "reallyDoIfToCase:t5=[" ++ (GHC.showRichTokenStream t5) ++ "]"
logm $ "reallyDoIfToCase:caseToks=" ++ (show caseToks)
void $ putToksForSpan l caseToks
return newExp
inExp e = return e
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
[
(GHC.noLoc $ GHC.Match
[
GHC.noLoc $ GHC.ConPatIn (GHC.noLoc trueName) (GHC.PrefixCon [])
]
Nothing
((GHC.GRHSs
[
GHC.noLoc $ GHC.GRHS [] e2
] GHC.EmptyLocalBinds))
)
, (GHC.noLoc $ GHC.Match
[
GHC.noLoc $ GHC.ConPatIn (GHC.noLoc falseName) (GHC.PrefixCon [])
]
Nothing
((GHC.GRHSs
[
GHC.noLoc $ GHC.GRHS [] e3
] GHC.EmptyLocalBinds))
)
] undefined))
return ret
ifToCaseTransform x = return x