HaRe-0.7.2.0: src/Language/Haskell/Refact/Refactoring/Case.hs
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
-- ---------------------------------------------------------------------
-- | Convert an if expression to a case expression
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) -- ++AZ++
let expr = locToExp beginPos endPos renamed
-- logm $ "Case.comp:expr=" ++ (SYB.showData SYB.Renamer 0 expr) -- ++AZ++
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!" -- ++ (show (beginPos,endPos,fileName)) ++ "]:" ++ (SYB.showData SYB.Parser 0 $ ast)
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
-- drawTokenTreeDetailed "reallyDoIfToCase" -- ++AZ++ debug
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
-- logm $ "reallyDoIfToCase:(t1++t2++t3++t4)=" ++ (show (t1++t2++t3++t4))
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:t1++t2++t3=" ++ (show (t1++t2++t3))
logm $ "reallyDoIfToCase:t4=[" ++ (GHC.showRichTokenStream t4) ++ "]"
logm $ "reallyDoIfToCase:t5=[" ++ (GHC.showRichTokenStream t5) ++ "]"
logm $ "reallyDoIfToCase:caseToks=" ++ (show caseToks)
-- drawTokenTreeDetailed "reallyDoIfToCase"
void $ putToksForSpan l caseToks
-- drawTokenTree "reallyDoIfToCase after putToks"
-- drawTokenTreeDetailed "reallyDoIfToCase after putToks"
return newExp
inExp e = return e
-- TODO: rearrange the structure and preserve the comments in the original, e.g. in e1,e2,e3
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
-- ---------------------------------------------------------------------
{-
HsIf (Maybe (SyntaxExpr id)) (LHsExpr id) (LHsExpr id) (LHsExpr id)
[Can ignore The SyntaxExpr]
HsCase (LHsExpr id) (MatchGroup id)
-}
{-
Need to move to
(L {test/testdata/Case/B.hs:(9,10)-(11,17)}
(HsCase
(L {test/testdata/Case/B.hs:9:15-21}
(HsPar
(L {test/testdata/Case/B.hs:9:16-20}
(HsApp
(L {test/testdata/Case/B.hs:9:16-18}
(HsVar {Name: GHC.Real.odd}))
(L {test/testdata/Case/B.hs:9:20}
(HsVar {Name: x}))))))
(MatchGroup
[
(L {test/testdata/Case/B.hs:10:3-15}
(Match
[
(L {test/testdata/Case/B.hs:10:3-6}
(ConPatIn
(L {test/testdata/Case/B.hs:10:3-6} {Name: GHC.Types.True})
(PrefixCon
[])))]
(Nothing)
(GRHSs
[
(L {test/testdata/Case/B.hs:10:11-15}
(GRHS
[]
(L {test/testdata/Case/B.hs:10:11-15}
(HsLit
(HsString {FastString: "Odd"})))))]
(EmptyLocalBinds)))),
(L {test/testdata/Case/B.hs:11:3-17}
(Match
[
(L {test/testdata/Case/B.hs:11:3-7}
(ConPatIn
(L {test/testdata/Case/B.hs:11:3-7} {Name: GHC.Types.False})
(PrefixCon
[])))]
(Nothing)
(GRHSs
[
(L {test/testdata/Case/B.hs:11:12-17}
(GRHS
[]
(L {test/testdata/Case/B.hs:11:12-17}
(HsLit
(HsString {FastString: "Even"})))))]
(EmptyLocalBinds))))] {!type placeholder here?!})))
from ---
(L {test/testdata/Case/B.hs:4:9-41}
(HsIf
(Nothing)
(L {test/testdata/Case/B.hs:4:12-18}
(HsPar
(L {test/testdata/Case/B.hs:4:13-17}
(HsApp
(L {test/testdata/Case/B.hs:4:13-15}
(HsVar {Name: GHC.Real.odd}))
(L {test/testdata/Case/B.hs:4:17}
(HsVar {Name: x}))))))
(L {test/testdata/Case/B.hs:4:25-29}
(HsLit
(HsString {FastString: "Odd"})))
(L {test/testdata/Case/B.hs:4:36-41}
(HsLit
(HsString {FastString: "Even"})))))
-}
-- EOF