HaRe 0.7.0.1 → 0.7.0.2
raw patch · 6 files changed
+187/−29 lines, 6 files
Files
- HaRe.cabal +1/−1
- src/Language/Haskell/Refact/Case.hs +130/−5
- src/Language/Haskell/Refact/Renaming.hs +0/−5
- src/Language/Haskell/Refact/Utils/GhcVersionSpecific.hs +11/−10
- src/Language/Haskell/Refact/Utils/LocUtils.hs +44/−7
- src/Language/Haskell/Refact/Utils/TypeUtils.hs +1/−1
HaRe.cabal view
@@ -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
src/Language/Haskell/Refact/Case.hs view
@@ -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
src/Language/Haskell/Refact/Renaming.hs view
@@ -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
src/Language/Haskell/Refact/Utils/GhcVersionSpecific.hs view
@@ -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
src/Language/Haskell/Refact/Utils/LocUtils.hs view
@@ -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 -- ---------------------------------------------------------------------
src/Language/Haskell/Refact/Utils/TypeUtils.hs view
@@ -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