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