diff --git a/HaRe.cabal b/HaRe.cabal --- a/HaRe.cabal +++ b/HaRe.cabal @@ -1,5 +1,5 @@ Name: HaRe -Version: 0.7.0.1 +Version: 0.7.0.2 Author: Chris Brown, Huiqing Li, Simon Thompson, Alan Zimmerman Maintainer: Alan Zimmerman Stability: Alpha diff --git a/src/Language/Haskell/Refact/Case.hs b/src/Language/Haskell/Refact/Case.hs --- a/src/Language/Haskell/Refact/Case.hs +++ b/src/Language/Haskell/Refact/Case.hs @@ -3,16 +3,18 @@ import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB - -import qualified GHC +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 -- --------------------------------------------------------------------- @@ -25,7 +27,9 @@ 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 @@ -49,12 +53,50 @@ return () where inExp :: (GHC.Located (GHC.HsExpr GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name)) - - inExp exp1@(GHC.L _ (GHC.HsIf _ _ _ _)) + 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 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 @@ -92,6 +134,89 @@ 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 diff --git a/src/Language/Haskell/Refact/Renaming.hs b/src/Language/Haskell/Refact/Renaming.hs --- a/src/Language/Haskell/Refact/Renaming.hs +++ b/src/Language/Haskell/Refact/Renaming.hs @@ -6,11 +6,7 @@ import qualified FastString as GHC import qualified GHC --- import qualified MonadUtils as GHC import qualified Name as GHC --- import qualified NameSet as GHC --- import qualified OccName as GHC --- import qualified Outputable as GHC import qualified RdrName as GHC import Control.Monad @@ -18,7 +14,6 @@ import Exception import Language.Haskell.GhcMod -import Language.Haskell.GhcMod.Internal import Language.Haskell.Refact.Utils import Language.Haskell.Refact.Utils.GhcUtils import Language.Haskell.Refact.Utils.GhcVersionSpecific diff --git a/src/Language/Haskell/Refact/Utils/GhcVersionSpecific.hs b/src/Language/Haskell/Refact/Utils/GhcVersionSpecific.hs --- a/src/Language/Haskell/Refact/Utils/GhcVersionSpecific.hs +++ b/src/Language/Haskell/Refact/Utils/GhcVersionSpecific.hs @@ -7,27 +7,18 @@ ( showGhc , prettyprint + , prettyprint2 , lexStringToRichTokens , getDataConstructors , setGhcContext ) where --- import qualified BasicTypes as GHC import qualified DynFlags as GHC --- import qualified FastString as GHC import qualified GHC as GHC import qualified GHC.Paths as GHC --- import qualified GhcMonad as GHC --- import qualified HsExpr as GHC --- import qualified HsSyn as GHC import qualified Lexer as GHC --- import qualified Module as GHC --- import qualified MonadUtils as GHC --- import qualified Name as GHC import qualified Outputable as GHC --- import qualified RdrName as GHC --- import qualified SrcLoc as GHC import qualified StringBuffer as GHC import Language.Haskell.Refact.Utils.TypeSyn @@ -54,6 +45,16 @@ #endif -- --------------------------------------------------------------------- + +prettyprint2 :: (GHC.Outputable a) => a -> String +#if __GLASGOW_HASKELL__ > 704 +prettyprint2 x = GHC.renderWithStyle GHC.tracingDynFlags (GHC.ppr x) (GHC.cmdlineParserStyle) +#else +prettyprint2 x = GHC.renderWithStyle (GHC.ppr x) (GHC.cmdlineParserStyle) +#endif + +-- --------------------------------------------------------------------- + lexStringToRichTokens :: GHC.RealSrcLoc -> String -> IO [PosToken] lexStringToRichTokens startLoc str = do diff --git a/src/Language/Haskell/Refact/Utils/LocUtils.hs b/src/Language/Haskell/Refact/Utils/LocUtils.hs --- a/src/Language/Haskell/Refact/Utils/LocUtils.hs +++ b/src/Language/Haskell/Refact/Utils/LocUtils.hs @@ -43,7 +43,7 @@ , getStartEndLoc2, startEndLoc,extendBothSides -},extendForwards,extendBackwards , startEndLocIncFowComment{- ,startEndLocIncFowNewLn -} - {- ++AZ++ moved to TokenUtils , startEndLocIncComments, startEndLocIncComments' -} + , startEndLocIncComments, startEndLocIncComments' {-, prettyprint ,deleteFromToks, prettyprintGuardsAlt, -} @@ -83,7 +83,6 @@ , fileNameFromTok , splitToks , emptyList, nonEmptyList - , startEndLocIncComments, startEndLocIncComments' , divideComments , isWhiteSpace , notWhiteSpace @@ -92,6 +91,8 @@ , isWhereOrLet , isWhere , isLet + , isElse + , isThen , getIndentOffset , splitOnNewLn , tokenLen @@ -1134,21 +1135,18 @@ startEndLocIncComments::(SYB.Data t) => [PosToken] -> t -> (SimpPos,SimpPos) startEndLocIncComments toks t = startEndLocIncComments' toks (getStartEndLoc t) - +{- startEndLocIncComments' :: [PosToken] -> (SimpPos,SimpPos) -> (SimpPos,SimpPos) startEndLocIncComments' toks (startLoc,endLoc) = let (begin,middle,end) = splitToks (startLoc,endLoc) toks - -- (leadinr,leadr) = break (\tok -> not (isComment tok || isEmpty tok)) $ reverse begin - (leadinr,leadr) = break notWhiteSpace $ reverse begin + (leadinr,leadr) = break notWhiteSpace $ reverse begin leadr' = filter (\t -> not (isEmpty t)) leadr prevLine = if (emptyList leadr') then 0 else (tokenRow $ ghead "startEndLocIncComments'1" leadr') firstLine = if (emptyList middle) then 0 else (tokenRow $ ghead "startEndLocIncComments'1" middle) (_,leadComments) = divideComments prevLine firstLine $ reverse leadinr - - -- (trail,trailrest) = break (\tok -> not (isComment tok || isEmpty tok)) end (trail,trailrest) = break notWhiteSpace end trail' = filter (\t -> not (isEmpty t)) trail lastLine = if (emptyList middle) then 0 else (tokenRow $ glast "startEndLocIncComments'2" middle) @@ -1161,8 +1159,37 @@ then ((0,0),(0,0)) else ((tokenPos $ ghead "startEndLocIncComments 4" middle'),(tokenPosEnd $ last middle')) -- else error $ "startEndLocIncComments: (prevLine,firstLine) reverse leadr =" ++ (show (prevLine,firstLine)) ++ "," ++ (showToks $ reverse leadr) +-} +startEndLocIncComments' :: [PosToken] -> (SimpPos,SimpPos) -> (SimpPos,SimpPos) +startEndLocIncComments' toks (startLoc,endLoc) = + let + (begin,middle,end) = splitToks (startLoc,endLoc) toks + notIgnored tt = not (isWhiteSpace tt || isThen tt || isElse tt) + + -- (leadinr,leadr) = break notWhiteSpace $ reverse begin + (leadinr,leadr) = break notIgnored $ reverse begin + leadr' = filter (\t -> not (isEmpty t)) leadr + prevLine = if (emptyList leadr') then 0 else (tokenRow $ ghead "startEndLocIncComments'1" leadr') + firstLine = if (emptyList middle) then 0 else (tokenRow $ ghead "startEndLocIncComments'1" middle) + (_nonleadComments,leadComments') = divideComments prevLine firstLine $ reverse leadinr + leadComments = dropWhile (\tt -> (isThen tt || isElse tt || isEmpty tt)) leadComments' + + (trail,trailrest) = break notWhiteSpace end + trail' = filter (\t -> not (isEmpty t)) trail + lastLine = if (emptyList middle) then 0 else (tokenRow $ glast "startEndLocIncComments'2" middle) + nextLine = if (emptyList trailrest) then 1000 else (tokenRow $ ghead "startEndLocIncComments'2" trailrest) + (trailComments,_) = divideComments lastLine nextLine trail' + + middle' = leadComments ++ middle ++ trailComments + in + if (emptyList middle') + then ((0,0),(0,0)) + else ((tokenPos $ ghead "startEndLocIncComments 4" middle'),(tokenPosEnd $ last middle')) + -- else error $ "startEndLocIncComments: (prevLine,firstLine) reverse leadr =" ++ (show (prevLine,firstLine)) ++ "," ++ (showToks $ reverse leadr) + -- else error $ "startEndLocIncComments: (prevLine,firstLine) reverse leadinr =" ++ (show (prevLine,firstLine)) ++ "," ++ (showToks $ reverse leadinr) ++ (show (_nonleadComments,leadComments')) + -- --------------------------------------------------------------------- -- |Split a set of comment tokens into the ones that belong with the startLine @@ -1246,6 +1273,16 @@ isLet :: PosToken -> Bool isLet ((GHC.L _ t),_s) = case t of GHC.ITlet -> True + _ -> False + +isElse :: PosToken -> Bool +isElse ((GHC.L _ t),_s) = case t of + GHC.ITelse -> True + _ -> False + +isThen :: PosToken -> Bool +isThen ((GHC.L _ t),_s) = case t of + GHC.ITthen -> True _ -> False -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/TypeUtils.hs b/src/Language/Haskell/Refact/Utils/TypeUtils.hs --- a/src/Language/Haskell/Refact/Utils/TypeUtils.hs +++ b/src/Language/Haskell/Refact/Utils/TypeUtils.hs @@ -114,7 +114,7 @@ , mkRdrName,mkNewGhcName,mkNewName,mkNewToplevelName -- The following functions are not in the the API yet. - , causeNameClashInExports {- , inRegion , unmodified -}, prettyprint + , causeNameClashInExports {- , inRegion , unmodified -}, prettyprint, prettyprint2 , removeOffset