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.IO.Class 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.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 everywhereMStaged SYB.Renamer (SYB.mkM inExp) rs 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 -- updateToks exp1 newExp prettyprint True -- updateToks exp1 newExp prettyprint2 True 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 ->" thenToks <- getToksForSpan l2 elseToks <- getToksForSpan l3 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: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" putToksForSpan l caseToks 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