HaRe-0.7.1.4: src/Language/Haskell/Refact/Case.hs
module Language.Haskell.Refact.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.Utils.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.TypeUtils
import Language.Haskell.Refact.Utils.TypeSyn
-- ---------------------------------------------------------------------
-- | 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