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



