diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2017-02-11 v0.8.4.0 + * Update for GHC 8.0.2 + * Use ghc-mod version to 5.7 + * Add deleteDef refactoring to generalise a monadic function + to use applicative (@SAdams601) + * Add genapplicative refactoring to generalise a monadic function + to use applicative (@SAdams601) 2016-08-03 v0.8.3.0 * Update for GHC 8.0.1 * Use ghc-mod version to 5.6 now it is released diff --git a/HaRe.cabal b/HaRe.cabal --- a/HaRe.cabal +++ b/HaRe.cabal @@ -1,6 +1,8 @@ Name: HaRe -Version: 0.8.3.0 -Author: Chris Brown, Huiqing Li, Simon Thompson, Alan Zimmerman +Version: 0.8.4.0 + +Author: Chris Brown, Huiqing Li, Simon Thompson, + Alan Zimmerman, Stephen Adams Maintainer: Alan Zimmerman (alan.zimm@gmail.com) Stability: Alpha Bug-Reports: http://github.com/RefactoringTools/HaRe/issues @@ -19,8 +21,10 @@ . From version 0.8.3.0, GHC 8.0.1 is supported. . - It is tested against GHC 7.10.3 and GHC 8.0.1 (via travis-ci.org) + From version 0.8.4.0, GHC 8.0.2 is supported. . + It is tested against GHC 7.10.3, GHC 8.0.1 and GHC 8.0.2 (via travis-ci.org) + . It currently only has emacs integration built in, community input welcome for others. . @@ -42,7 +46,7 @@ Cabal-Version: >= 1.8 Build-Type: Simple -tested-with: GHC == 7.10.3, GHC == 8.0.1 +tested-with: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2 data-files: elisp/*.el configure.sh @@ -115,34 +119,33 @@ Library -- GHC 7.10.2 ships with base 4.8.1.0 Build-Depends: base >= 4.8.1.0 && < 5 - , containers - , directory - - , semigroups - , monoid-extras - - , cabal-helper - , filepath - , ghc - , ghc-paths - , ghc-prim - , ghc-syb-utils - , ghc-mod >= 5.6.0.0 - , mtl - , old-time - , pretty - , rosezipper - , syb - , hslogger - , transformers - , transformers-base - , time - , Strafunski-StrategyLib - , syz - , ghc-exactprint >= 0.5.2.1 - , monad-control - , Cabal >= 1.22 + , Strafunski-StrategyLib + , cabal-helper + , containers + , directory + , filepath + , ghc + , ghc-exactprint == 0.5.3.* + , ghc-mod == 5.7.0.* + , ghc-syb-utils + , hslogger + , monad-control + , mtl + , syb + , syz + -- optimisation disabled otherwise the compile takes too long + -- With normal optimisation, we get + -- $ rm -fr dist-newstyle/ + -- $ cabal new-configure --enable-test + -- $ time cabal new-build + -- real 6m54.778s + -- user 7m3.156s + -- sys 0m4.504s + -- With -O0, the timing is + -- real 0m36.427s + -- user 0m41.448s + -- sys 0m2.544s GHC-Options: -O0 Hs-Source-Dirs: src -- Other-Modules: Paths_HaRe @@ -157,6 +160,10 @@ , Language.Haskell.Refact.Refactoring.RoundTrip , Language.Haskell.Refact.Refactoring.Simple , Language.Haskell.Refact.Refactoring.SwapArgs + , Language.Haskell.Refact.Refactoring.DeleteDef +-- , Language.Haskell.Refact.Refactoring.IntroduceTypeSyn +-- , Language.Haskell.Refact.Refactoring.UnwrapTypeSyn + , Language.Haskell.Refact.Refactoring.GenApplicative , Language.Haskell.Refact.Utils.ExactPrint , Language.Haskell.Refact.Utils.GhcBugWorkArounds , Language.Haskell.Refact.Utils.GhcModuleGraph @@ -170,6 +177,9 @@ , Language.Haskell.Refact.Utils.Types , Language.Haskell.Refact.Utils.Utils , Language.Haskell.Refact.Utils.Variables + , Language.Haskell.Refact.Utils.Synonyms + , Language.Haskell.Refact.Utils.Transform + , Language.Haskell.Refact.Utils.Query , Paths_HaRe if impl (ghc < 7.10.2) buildable: False @@ -181,44 +191,18 @@ GHC-Options: -O0 -- GHC-Options: -prof -fprof-auto -rtsopts -caf-all Hs-Source-Dirs: - ./src + ./app -- GHC 7.10.2 ships with base 4.8.1.0 Build-Depends: base >= 4.8.1.0 && < 5 - , array - , containers - , directory - - , semigroups - , monoid-extras - - , cabal-helper - , filepath - , ghc - , ghc-paths - , ghc-prim - , ghc-syb-utils + , ghc-mod , gitrev >= 1.1 - , ghc-mod >= 5.6.0.0 , mtl , optparse-applicative , optparse-simple - , old-time - , parsec >= 3.1.6 - , pretty - , rosezipper - , syb - , time - , transformers - , transformers-base - , hslogger - , Strafunski-StrategyLib - , syz - , ghc-exactprint >= 0.5.2.1 - , monad-control - , Cabal >= 1.22 + , Cabal -- , Paths_HaRe - , HaRe >= 0.8.2.1 + , HaRe Extensions: CPP if impl (ghc < 7.10.2) buildable: False @@ -236,9 +220,9 @@ cpp-options: -DTEST main-is: - Spec.hs + Main.hs Hs-Source-Dirs: - src + -- src test other-modules: AddRmParamSpec @@ -255,6 +239,9 @@ , TestUtils , TypeUtilsSpec , UtilsSpec + , DeleteDefSpec +-- , IntroduceTypeSynSpec +-- , UnwrapTypeSynSpec -- , Language.Haskell.Refact.API -- , Language.Haskell.Refact.HaRe @@ -279,39 +266,26 @@ base >= 4.8.1.0 && < 5 , Diff >= 0.3.0 , HUnit - , QuickCheck >= 2.5 , containers - - , cabal-helper - , semigroups - , monoid-extras - - , deepseq , directory - , filepath + , foldl , ghc - , ghc-paths - , ghc-prim + , ghc-exactprint == 0.5.3.* + , ghc-mod == 5.7.0.* , ghc-syb-utils - , ghc-mod >= 5.6.0.0 + , hslogger , hspec , mtl - , old-time - , process - , silently - , stringbuilder - , rosezipper - , syb - , transformers - , transformers-base - , time - , hslogger - , Strafunski-StrategyLib - , syz - , ghc-exactprint >= 0.5.2.1 - , monad-control - , Cabal >= 1.22 + , turtle >= 1.3.0 + , foldl -- , Paths_HaRe + , attoparsec + , base-prelude + , conversion-case-insensitive + , conversion + , conversion-text + , parsec + , case-insensitive , HaRe >= 0.8.2.1 Extensions: CPP if impl (ghc < 7.10.2) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,2 @@ import Distribution.Simple main = defaultMain - diff --git a/app/MainHaRe.hs b/app/MainHaRe.hs new file mode 100644 --- /dev/null +++ b/app/MainHaRe.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +import Control.Exception +import Control.Monad.Writer.Lazy +import Data.List +import Data.Version +import Development.GitRev (gitCommitCount) +import Distribution.System (buildArch) +import Distribution.Text (display) +import Language.Haskell.Refact.API +import Language.Haskell.Refact.HaRe +import Options.Applicative.Simple +import qualified Language.Haskell.GhcMod as GM +import qualified Paths_HaRe as Meta + +-- temporary until exposed by ghc-mod +-- import Options +import Language.Haskell.GhcMod.Options.Options + +main :: IO () +main = do + -- Version code from stack. Maybe move this stuff into optparse-simple ? + let commitCount = $gitCommitCount + versionString' = concat $ concat + [ [$(simpleVersion Meta.version)] + -- Leave out number of commits for --depth=1 clone + -- See https://github.com/commercialhaskell/stack/issues/792 + , [" (" ++ commitCount ++ " commits)" | commitCount /= ("1"::String) && + commitCount /= ("UNKNOWN" :: String)] + , [" ", display buildArch] + ] + numericVersion :: Parser (a -> a) + numericVersion = + infoOption + (showVersion Meta.version) + (long "numeric-version" <> + help "Show only version number") + -- Parse the options and run the specified command. + (global, run) <- + simpleOptions + versionString' + "HaRe - the haskell refactorer" + "" + -- (numericVersion <*> globalOptsParser) $ + (numericVersion <*> allOptsParser) $ + do + addCommand "demote" + "Demote a declaration" + runCmd + demoteCmdOpts + + addCommand "dupdef" + "Duplicate a definition" + runCmd + dupDefCmdOpts + + addCommand "iftocase" + "Convert an if statement to a case statement" + runCmd + ifToCaseCmdOpts + + addCommand "liftOneLevel" + "Lift a definition up one level" + runCmd + liftOneLevelCmdOpts + + addCommand "liftToTopLevel" + "Lift a definition to the top level" + runCmd + liftToTopLevelCmdOpts + + addCommand "rename" + "Rename an identifier" + runCmd + renameCmdOpts + + addCommand "addOneParam" + "Add a new parameter to a function in first position" + runCmd + addOneParamCmdOpts + + addCommand "rmOneParam" + "Remove a new parameter from a function" + runCmd + rmOneParamCmdOpts + + addCommand "genApplicative" + "Generalise a monadic function to use applicative" + runCmd + genApplicativeOpts + + addCommand "deleteDef" + "Delete a definition" + runCmd + deleteDefOpts + run global + +-- --------------------------------------------------------------------- + +type Row = Int +type Col = Int + +data HareParams = DemoteCmd FilePath Row Col + | DupDefCmd FilePath String Row Col + | IfToCaseCmd FilePath Row Col Row Col + | LiftOneLevel FilePath Row Col + | LiftToTopLevel FilePath Row Col + | RenameCmd FilePath String Row Col + | AddOneParam FilePath String Row Col + | RmOneParam FilePath Row Col + | GenApplicative FilePath String Row Col + | DeleteDef FilePath Row Col + deriving Show + +runCmd :: HareParams -> (RefactSettings,GM.Options) -> IO () +runCmd (DemoteCmd fileName r c) (opt, gOpt) + = runFunc $ demote opt gOpt fileName (r,c) + +runCmd (DupDefCmd fileName newname r c) (opt, gOpt) + = runFunc $ duplicateDef opt gOpt fileName newname (r,c) + +runCmd (IfToCaseCmd fileName sr sc er ec) (opt, gOpt) + = runFunc $ ifToCase opt gOpt fileName (sr,sc) (er,ec) + +runCmd (LiftOneLevel fileName r c) (opt, gOpt) + = runFunc $ liftOneLevel opt gOpt fileName (r,c) + +runCmd (LiftToTopLevel fileName r c) (opt, gOpt) + = runFunc $ liftToTopLevel opt gOpt fileName (r,c) + +runCmd (RenameCmd fileName newname r c) (opt, gOpt) + = runFunc $ rename opt gOpt fileName newname (r,c) + +runCmd (AddOneParam fileName newname r c) (opt, gOpt) + = runFunc $ addOneParameter opt gOpt fileName newname (r,c) + +runCmd (RmOneParam fileName r c) (opt, gOpt) + = runFunc $ rmOneParameter opt gOpt fileName (r,c) + +runCmd (GenApplicative fileName funNm r c) (opt, gOpt) + = runFunc $ genApplicative opt gOpt fileName funNm (r,c) + +runCmd (DeleteDef fileName r c) (opt, gOpt) + = runFunc $ deleteDef opt gOpt fileName (r,c) + +rmOneParamCmdOpts :: Parser HareParams +rmOneParamCmdOpts = + RmOneParam + <$> strArgument + ( metavar "FILE" + <> help "Specify Haskell file to process" + ) + <*> argument auto + ( metavar "line" + <> help "The line the function name is on") + <*> argument auto + ( metavar "col" + <> help "The col the function name starts at") + +-- --------------------------------------------------------------------- + +addOneParamCmdOpts :: Parser HareParams +addOneParamCmdOpts = + AddOneParam + <$> strArgument + ( metavar "FILE" + <> help "Specify Haskell file to process" + ) + <*> strArgument + ( metavar "NAME" + <> help "The name for the parameter" + ) + <*> argument auto + ( metavar "line" + <> help "The line the function name is on") + <*> argument auto + ( metavar "col" + <> help "A col inside the function name name") + +-- --------------------------------------------------------------------- + +renameCmdOpts :: Parser HareParams +renameCmdOpts = + RenameCmd + <$> strArgument + ( metavar "FILE" + <> help "Specify Haskell file to process" + ) + <*> strArgument + ( metavar "NEWNAME" + <> help "The new name for the identifier" + ) + <*> argument auto + ( metavar "line" + <> help "The line the identifier is on") + <*> argument auto + ( metavar "col" + <> help "A col inside the identifier name") + +-- --------------------------------------------------------------------- + +liftToTopLevelCmdOpts :: Parser HareParams +liftToTopLevelCmdOpts = + LiftToTopLevel + <$> strArgument + ( metavar "FILE" + <> help "Specify Haskell file to process" + ) + <*> argument auto + ( metavar "line" + <> help "The line the declaration is on") + <*> argument auto + ( metavar "col" + <> help "The col the declaration starts at") + +-- --------------------------------------------------------------------- + +liftOneLevelCmdOpts :: Parser HareParams +liftOneLevelCmdOpts = + LiftOneLevel + <$> strArgument + ( metavar "FILE" + <> help "Specify Haskell file to process" + ) + <*> argument auto + ( metavar "line" + <> help "The line the declaration is on") + <*> argument auto + ( metavar "col" + <> help "The col the declaration starts at") + +-- --------------------------------------------------------------------- + +ifToCaseCmdOpts :: Parser HareParams +ifToCaseCmdOpts = + IfToCaseCmd + <$> strArgument + ( metavar "FILE" + <> help "Specify Haskell file to process" + ) + <*> argument auto + ( metavar "startline" + <> help "The line the if statement starts on") + <*> argument auto + ( metavar "startcol" + <> help "The col the if statement starts at") + + <*> argument auto + ( metavar "endline" + <> help "The line the if statement ends on") + <*> argument auto + ( metavar "endcol" + <> help "The col the if statement ends at") + +-- --------------------------------------------------------------------- + +demoteCmdOpts :: Parser HareParams +demoteCmdOpts = + DemoteCmd + <$> strArgument + ( metavar "FILE" + <> help "Specify Haskell file to process" + ) + <*> argument auto + ( metavar "line" + <> help "The line the declaration is on") + <*> argument auto + ( metavar "col" + <> help "The col the declaration starts at") + +dupDefCmdOpts :: Parser HareParams +dupDefCmdOpts = + DupDefCmd + <$> strArgument + ( metavar "FILE" + <> help "Specify Haskell file to process" + ) + <*> strArgument + ( metavar "NEWNAME" + <> help "The name for the new definition" + ) + <*> argument auto + ( metavar "line" + <> help "The line the definition is on") + <*> argument auto + ( metavar "col" + <> help "A col inside the definition name") + +genApplicativeOpts :: Parser HareParams +genApplicativeOpts = + GenApplicative + <$> strArgument + ( metavar "FILE" + <> help "Specify Haskell file to process" + ) + <*> strArgument + ( metavar "FUNNAME" + <> help "The name of the function to be refactored" + ) + <*> argument auto + ( metavar "line" + <> help "The line the definition is on") + <*> argument auto + ( metavar "col" + <> help "A col inside the definition name") + +-- --------------------------------------------------------------------- + +deleteDefOpts :: Parser HareParams +deleteDefOpts = + DeleteDef + <$> strArgument + ( metavar "FILE" + <> help "Specify Haskell file to process" + ) + <*> argument auto + ( metavar "line" + <> help "The line the declaration is on") + <*> argument auto + ( metavar "col" + <> help "The col the declaration starts at") + + + +-- --------------------------------------------------------------------- + +allOptsParser :: Parser (RefactSettings,GM.Options) +allOptsParser = (,) <$> globalOptsParser <*> globalArgSpec + +globalOptsParser :: Parser RefactSettings +globalOptsParser = mkRefSet + <$> ((\b -> if b then Debug else Normal) <$> switch + ( long "debug" + <> short 'd' + <> help "Generate debug output" )) + where + mkRefSet v = RefSet v (True,True,True,True) + +-- --------------------------------------------------------------------- + +-- | Return the result of an Either as a sexp for emacs etc. +runFunc :: IO [String] -> IO () +runFunc f = do + r <- catchException f + let ret = case r of + Left s -> "(error " ++ (show s) ++ ")" + Right mfs -> "(ok " ++ showLisp mfs ++ ")" + putStrLn ret + +showLisp :: [String] -> String +showLisp xs = "(" ++ (intercalate " " $ map (\str -> "\"" ++ unixSlashes str ++ "\"") xs) ++ ")" + where unixSlashes = map (\c -> if c == '\\' then '/' else c) + +catchException :: (IO t) -> IO (Either String t) +catchException f = do + res <- handle handler (f >>= \r -> return $ Right r) + return res + where + handler:: SomeException -> IO (Either String t) + handler e = return (Left (stripCallStack $ show e)) diff --git a/src/Language/Haskell/Refact/API.hs b/src/Language/Haskell/Refact/API.hs --- a/src/Language/Haskell/Refact/API.hs +++ b/src/Language/Haskell/Refact/API.hs @@ -22,7 +22,6 @@ , logDataWithAnns , logExactprint , logParsedSource - -- * from `Language.Haskell.Refact.Utils.Utils` -- ** Managing the GHC / project environment @@ -31,7 +30,9 @@ -- ** The bits that do the work , runRefacSession + , runMultRefacSession , applyRefac + , applyRefac' , refactDone , ApplyRefacResult , RefacSource(..) @@ -41,6 +42,7 @@ , getModuleName , clientModsAndFiles , serverModsAndFiles + -- , lookupAnns , stripCallStack @@ -78,6 +80,7 @@ , setStateStorage , getStateStorage + , fetchAnnsFinal -- * Parsing source , parseDeclWithAnns @@ -95,8 +98,10 @@ , getLocatedEnd , getStartEndLoc , startEndLocGhc - , emptyList, nonEmptyList + , emptyList + , nonEmptyList + -- * from `Language.Haskell.Refact.Utils.TypeSyn` , InScopes , ghead @@ -130,6 +135,8 @@ , hsFDsFromInsideRdr, hsFDNamesFromInsideRdr, hsFDNamesFromInsideRdrPure , hsVisibleDsRdr , rdrName2Name, rdrName2NamePure + , eqRdrNamePure + , sameNameSpace -- *** Property checking ,isVarId,isConId,isOperator,isTopLevelPN,isLocalPN,isNonLibraryName -- ,isTopLevelPNT @@ -153,7 +160,7 @@ -- *** Locations ,defineLoc, useLoc, locToExp ,findLRdrName - -- ,locToName + ,locToNameRdr ,locToNameRdrPure ,locToRdrName ,getName @@ -198,6 +205,7 @@ , everywhereStaged , everywhereStaged' , listifyStaged + , everywhereButM -- ** Scrap Your Zipper versions , zeverywhereStaged @@ -225,11 +233,48 @@ -- * from `Language.Haskell.Refact.Utils.ExactPrint'` , replace , setRefactAnns + , mergeRefactAnns , setAnnKeywordDP , copyAnn , clearPriorComments , balanceAllComments + , exactPrintParsed + , exactPrintExpr + , zeroDP + , setDP + , handleParseResult + , removeAnns + , synthesizeAnns + , addNewKeyword + , addNewKeywords + + , addEmptyAnn + , addAnnVal + , addAnn + + -- from Language.Haskell.Refact.Utils.Synonyms + , UnlocParsedHsBind + , ParsedGRHSs + , ParsedMatchGroup + , ParsedLMatch + , ParsedExpr + , ParsedLStmt + , ParsedLExpr + , ParsedBind + + -- from Language.Haskell.Refact.Utils.Transform + , addSimpleImportDecl + , wrapInLambda + , wrapInPars + , removePars + , addNewLines + , wrapInParsWithDPs + , locate +-- from Language.Haskell.Refact.Utils.Query + , getVarAndRHS + , getHsBind + , isHsVar ) where import Language.Haskell.Refact.Utils.ExactPrint @@ -243,6 +288,7 @@ import Language.Haskell.Refact.Utils.Types import Language.Haskell.Refact.Utils.Utils import Language.Haskell.Refact.Utils.Variables - +import Language.Haskell.Refact.Utils.Transform import Language.Haskell.GHC.ExactPrint.Utils - +import Language.Haskell.Refact.Utils.Synonyms +import Language.Haskell.Refact.Utils.Query diff --git a/src/Language/Haskell/Refact/HaRe.hs b/src/Language/Haskell/Refact/HaRe.hs --- a/src/Language/Haskell/Refact/HaRe.hs +++ b/src/Language/Haskell/Refact/HaRe.hs @@ -19,9 +19,12 @@ , rename, compRename , addOneParameter, compAddOneParameter , rmOneParameter, compRmOneParameter + , deleteDef, compDeleteDef -- , swapArgs , roundTrip - +-- , introduceTypeSyn +-- , unwrapTypeSyn + , genApplicative, compGenApplicative ) where @@ -30,6 +33,10 @@ import Language.Haskell.Refact.Refactoring.DupDef import Language.Haskell.Refact.Refactoring.MoveDef import Language.Haskell.Refact.Refactoring.Renaming +--import Language.Haskell.Refact.Refactoring.IntroduceTypeSyn +import Language.Haskell.Refact.Refactoring.DeleteDef +--import Language.Haskell.Refact.Refactoring.UnwrapTypeSyn +import Language.Haskell.Refact.Refactoring.GenApplicative -- import Language.Haskell.Refact.Refactoring.SwapArgs import Language.Haskell.Refact.Refactoring.RoundTrip import Language.Haskell.Refact.Utils.Monad diff --git a/src/Language/Haskell/Refact/Refactoring/AddRmParam.hs b/src/Language/Haskell/Refact/Refactoring/AddRmParam.hs --- a/src/Language/Haskell/Refact/Refactoring/AddRmParam.hs +++ b/src/Language/Haskell/Refact/Refactoring/AddRmParam.hs @@ -365,7 +365,7 @@ #else let lname = GHC.L lv argPName let e2 = GHC.L lv (GHC.HsVar lname) - liftT $ addSimpleAnnT e2 (DP (0,1)) [((G GHC.AnnVal),DP (0,0))] + liftT $ addSimpleAnnT lname (DP (0,1)) [((G GHC.AnnVal),DP (0,0))] #endif let ret = GHC.L lp (GHC.HsPar (GHC.L la (GHC.HsApp expr e2))) liftT $ addSimpleAnnT ret (DP (0,0)) [((G GHC.AnnOpenP),DP (0,0)),((G GHC.AnnCloseP),DP (0,0))] diff --git a/src/Language/Haskell/Refact/Refactoring/DeleteDef.hs b/src/Language/Haskell/Refact/Refactoring/DeleteDef.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Refact/Refactoring/DeleteDef.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Language.Haskell.Refact.Refactoring.DeleteDef + (deleteDef, compDeleteDef) where + +import qualified Data.Generics as SYB +import qualified GHC.SYB.Utils as SYB +import BasicTypes +import qualified GHC +import Control.Monad +import Control.Monad.State +import Language.Haskell.GhcMod +import Language.Haskell.Refact.API +import Data.Generics.Strafunski.StrategyLib.StrategyLib +import qualified Language.Haskell.GhcMod as GM +import qualified Language.Haskell.GhcMod.Internal as GM +import System.Directory +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Types + +deleteDef :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath] +deleteDef settings cradle fileName (row,col) = do + absFileName <- canonicalizePath fileName + runRefacSession settings cradle (compDeleteDef absFileName (row,col)) + +compDeleteDef ::FilePath -> SimpPos -> RefactGhc [ApplyRefacResult] +compDeleteDef fileName (row,col) = do + parseSourceFileGhc fileName + renamed <- getRefactRenamed + parsed <- getRefactParsed + targetModule <- getRefactTargetModule + m <- getModule + let (Just (modName,_)) = getModuleName parsed + maybeRdrPn = locToRdrName (row,col) parsed + case maybeRdrPn of + Just pn@(GHC.L _ n) -> + do + logm $ "DeleteDef.comp: before isPNUsed" + Just ghcn <- locToNameRdr (row,col) parsed + pnIsUsedLocal <- isPNUsed ghcn targetModule fileName + clients <- clientModsAndFiles targetModule + pnUsedClients <- isPNUsedInClients ghcn n targetModule + if (pnIsUsedLocal || pnUsedClients) + then error "The def to be deleted is still being used" + else do + logm $ "Result of is used: " ++ (show pnIsUsedLocal) ++ " pnUsedClients: " ++ (show pnUsedClients) + (refRes@((_fp,ismod), (anns,ps)),()) <- applyRefac (doDeletion ghcn) RSAlreadyLoaded + case (ismod) of + RefacUnmodifed -> do + error "The def deletion failed" + RefacModified -> return () + logm $ "Res after delete === " ++ (exactPrint ps anns) + return [refRes] + Nothing -> error "Invalid cursor position!" + + +isPNUsed :: GHC.Name -> GM.ModulePath -> FilePath -> RefactGhc Bool +isPNUsed pn modPath filePath = do + renamed <- getRefactRenamed + pnUsedInScope pn renamed + + +pnUsedInScope :: (SYB.Data t) => GHC.Name -> t -> RefactGhc Bool +pnUsedInScope pn t' = do + logm $ "Start of pnUsedInScope" + res <- applyTU (stop_tdTU (failTU `adhocTU` bind `adhocTU` var)) t' + return $ (length res) > 0 + where +#if __GLASGOW_HASKELL__ <= 710 + bind ((GHC.FunBind (GHC.L l name) _ match _ _ _) :: GHC.HsBindLR GHC.Name GHC.Name) +#else + bind ((GHC.FunBind (GHC.L l name) match _ _ _) :: GHC.HsBindLR GHC.Name GHC.Name) +#endif + | name == pn = do + logm $ "Found Binding at: " ++ (showGhc l) + return [] + bind other = do + mzero +#if __GLASGOW_HASKELL__ <= 710 + var ((GHC.HsVar name) :: GHC.HsExpr GHC.Name) +#else + var ((GHC.HsVar (GHC.L _ name)) :: GHC.HsExpr GHC.Name) +#endif + | name == pn = do + logm $ "Found var" + return [pn] + var other = do + mzero + + +isPNUsedInClients :: GHC.Name -> GHC.RdrName -> GM.ModulePath -> RefactGhc Bool +isPNUsedInClients pn rdrn modPath = do + pnIsExported <- isExported pn + if pnIsExported + then do clients <- clientModsAndFiles modPath + logm $ "DeleteDef : clients: " ++ (showGhc clients) + res <- foldM (pnUsedInClientScope pn) False clients + return res + else do return False + +pnUsedInClientScope :: GHC.Name -> Bool -> TargetModule -> RefactGhc Bool +pnUsedInClientScope name b mod = do + getTargetGhc mod + isInScope <- isInScopeAndUnqualifiedGhc (nameToString name) Nothing + logm $ "The module file path: " ++ (show (GM.mpPath mod)) ++ "\n is pn in scope: " ++ (show isInScope) + return (b || isInScope) + +doDeletion :: GHC.Name -> RefactGhc () +doDeletion n = do + parsed <- getRefactParsed + (res, _decl, _mSig) <- rmDecl n True parsed + putRefactParsed res emptyAnns + return () diff --git a/src/Language/Haskell/Refact/Refactoring/DupDef.hs b/src/Language/Haskell/Refact/Refactoring/DupDef.hs --- a/src/Language/Haskell/Refact/Refactoring/DupDef.hs +++ b/src/Language/Haskell/Refact/Refactoring/DupDef.hs @@ -159,7 +159,7 @@ = filter (\d->isFunBindP d || isSimplePatDecl d) $ definingDeclsRdrNames nm [n] ds True False - doDuplicating' :: (SYB.Typeable t,SYB.Data t) => GHC.Name -> t -> GHC.Located GHC.Name -> RefactGhc t + doDuplicating' :: (SYB.Data t) => GHC.Name -> t -> GHC.Located GHC.Name -> RefactGhc t doDuplicating' newNameGhc t _ln = do logm $ "doDuplicating' entered" -- logm $ "doDuplicating' entered:t=" ++ SYB.showData SYB.Parser 0 t diff --git a/src/Language/Haskell/Refact/Refactoring/GenApplicative.hs b/src/Language/Haskell/Refact/Refactoring/GenApplicative.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Refact/Refactoring/GenApplicative.hs @@ -0,0 +1,357 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Language.Haskell.Refact.Refactoring.GenApplicative + (genApplicative, compGenApplicative) where + +import Language.Haskell.Refact.API +import qualified Language.Haskell.GhcMod as GM +import qualified GHC as GHC +import qualified RdrName as GHC +import System.Directory +import FastString +import Data.Map as Map (union) +import Data.Generics as SYB +import GHC.SYB.Utils as SYB +import Data.List +import Control.Monad +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Print +import Language.Haskell.GHC.ExactPrint.Parsers + +genApplicative :: RefactSettings -> GM.Options -> FilePath -> String -> SimpPos -> IO [FilePath] +genApplicative settings cradle fileName funNm pos = do + absFileName <- canonicalizePath fileName + runRefacSession settings cradle (compGenApplicative absFileName funNm pos) + +compGenApplicative :: FilePath -> String -> SimpPos -> RefactGhc [ApplyRefacResult] +compGenApplicative fileName funNm pos = do + (refRes@((_fp,ismod),_), ()) <- applyRefac (doGenApplicative fileName funNm pos) (RSFile fileName) + case ismod of + RefacUnmodifed -> error "Generalise to Applicative failed" + RefacModified -> return () + return [refRes] + +--The general operation of this refactoring involves transposing the LHsExpr's from within the list of ExprLStmt's +-- to an (OpApp :: HsExpr) +-- The function begins by constructing the beginning of the applicative chain by looking at the construction of the return statement + +doGenApplicative :: FilePath -> String -> SimpPos -> RefactGhc () +doGenApplicative fileName funNm pos = do + parsed <- getRefactParsed + let Just funBind = getHsBind pos funNm parsed + (Just retRhs) = getReturnRhs funBind + (Just doStmts) = getDoStmts funBind + boundVars = findBoundVars doStmts + checkPreconditions retRhs doStmts boundVars + appChain <- constructAppChain retRhs doStmts + replaceFunRhs funNm pos appChain + + +checkPreconditions :: ParsedExpr -> [GHC.ExprLStmt GHC.RdrName] -> [GHC.RdrName] -> RefactGhc () +checkPreconditions retRhs doStmts boundVars = do + let boundVarsPrecon = checkBVars doStmts boundVars + retVarsOrder = varOrdering boundVars retRhs + orderingPrecon = checkOrdering retVarsOrder doStmts + if (not boundVarsPrecon) + then error "GenApplicative Precondition: The function given uses a bound variable in a RHS expression." + else if (not orderingPrecon) + then error "GenApplicative Precondition: Variables are not bound in the order that they appear in the return statement." + else return () + where checkBVars [] _ = True + checkBVars (stmt:stmts) vars = case stmt of + (GHC.L _ (GHC.BodyStmt body _ _ _)) -> (not (lexprContainsVars vars body)) && (checkBVars stmts vars) +#if __GLASGOW_HASKELL__ <= 710 + (GHC.L _ (GHC.BindStmt _ body _ _)) -> (not (lexprContainsVars vars body)) && (checkBVars stmts vars) +#else + (GHC.L _ (GHC.BindStmt _ body _ _ _)) -> (not (lexprContainsVars vars body)) && (checkBVars stmts vars) +#endif + lexprContainsVars :: [GHC.RdrName] -> ParsedLExpr -> Bool + lexprContainsVars vars = SYB.everything (||) (False `SYB.mkQ` (\nm -> elem nm vars)) + varOrdering :: [GHC.RdrName] -> ParsedExpr -> [GHC.RdrName] + varOrdering boundVars = SYB.everything (++) ([] `SYB.mkQ` (\nm -> if (elem nm boundVars) then [nm] else [])) + checkOrdering :: [GHC.RdrName] -> [GHC.ExprLStmt GHC.RdrName] -> Bool + checkOrdering [] [] = True + checkOrdering [] ((GHC.L _ (GHC.BodyStmt _ _ _ _)):stmts) = checkOrdering [] stmts + checkOrdering vars ((GHC.L _ (GHC.BodyStmt _ _ _ _)):stmts) = checkOrdering vars stmts +#if __GLASGOW_HASKELL__ <= 710 + checkOrdering (var:vars) ((GHC.L _ (GHC.BindStmt pat _ _ _)):stmts) = +#else + checkOrdering (var:vars) ((GHC.L _ (GHC.BindStmt pat _ _ _ _)):stmts) = +#endif + if (checkPat var pat) + then (checkOrdering vars stmts) + else False + checkPat var pat = gContains var pat + +gContains :: (Data t, Eq a, Data a) => a -> t -> Bool +gContains item t = SYB.everything (||) (False `SYB.mkQ` (\b -> item == b)) t + +replaceFunRhs :: String -> SimpPos -> ParsedLExpr -> RefactGhc () +replaceFunRhs funNm pos newRhs = do + parsed <- getRefactParsed + let rdrNm = locToRdrName pos parsed + case rdrNm of + Nothing -> error "replaceFunRhs: Position does not correspond to a binding." + (Just (GHC.L _ rNm)) -> do + newParsed <- everywhereMStaged SYB.Parser (SYB.mkM (worker rNm)) parsed + putRefactParsed newParsed emptyAnns + logParsedSource "GenApplicative.replaceFunRhs" + where worker :: GHC.RdrName -> ParsedBind -> RefactGhc (GHC.HsBind GHC.RdrName) +#if __GLASGOW_HASKELL__ <= 710 + worker rNm fBind@(GHC.FunBind (GHC.L _ fNm) _ mg _ _ _) +#else + worker rNm fBind@(GHC.FunBind (GHC.L _ fNm) mg _ _ _) +#endif + | fNm == rNm = do + newMg <- replaceMG mg + return $ fBind{GHC.fun_matches = newMg} + | otherwise = return fBind + worker _ bind = return bind + replaceMG :: ParsedMatchGroup -> RefactGhc ParsedMatchGroup + replaceMG mg = do +#if __GLASGOW_HASKELL__ <= 710 + let [(GHC.L l match)] = GHC.mg_alts mg +#else + let (GHC.L _ [(GHC.L l match)]) = GHC.mg_alts mg +#endif + oldGrhss = GHC.m_grhss match + newGrhss = mkGrhss oldGrhss newRhs + newLMatch = (GHC.L l (match{GHC.m_grhss = newGrhss})) +#if __GLASGOW_HASKELL__ <= 710 + return mg{GHC.mg_alts = [newLMatch]} +#else + lMatchLst <- locate [newLMatch] + return mg{GHC.mg_alts = lMatchLst} +#endif + mkGrhss old newExpr = let [(GHC.L l (GHC.GRHS lst _))] = GHC.grhssGRHSs old in + old{GHC.grhssGRHSs = [(GHC.L l (GHC.GRHS lst newExpr))]} + + + +processReturnStatement :: ParsedExpr -> [GHC.RdrName] -> RefactGhc (Maybe ParsedLExpr) +processReturnStatement retExpr boundVars + | isJustBoundVar retExpr boundVars = return Nothing + | otherwise = + case retExpr of + (GHC.ExplicitTuple lst _) -> do + dFlags <- GHC.getSessionDynFlags + let commas = repeat ',' + constr = "(" ++ (take ((length lst)-1) commas) ++ ")" + parseRes = parseExpr dFlags "hare" constr + case parseRes of + (Left (_, errMsg)) -> do + logm "processReturnStatement: error parsing tuple constructor" + return Nothing + (Right (anns, expr)) -> do + mergeRefactAnns anns + return (Just expr) + _ -> do + lRet <- locate retExpr + stripBoundVars lRet boundVars + where stripBoundVars :: ParsedLExpr -> [GHC.RdrName] -> RefactGhc (Maybe ParsedLExpr) +#if __GLASGOW_HASKELL__ <= 710 + stripBoundVars le@(GHC.L l (GHC.HsVar nm)) names = +#else + stripBoundVars le@(GHC.L l (GHC.HsVar (GHC.L _ nm))) names = +#endif + if (elem nm names) + then return Nothing + else return (Just le) + stripBoundVars (GHC.L l (GHC.HsApp expr1 expr2)) names = do + ne1 <- stripBoundVars expr1 names + ne2 <- stripBoundVars expr2 names + case ne2 of + Nothing -> return ne1 + (Just e2) -> return (ne1 >>= (\e1 -> Just (GHC.L l (GHC.HsApp e1 e2)))) + +isJustBoundVar :: ParsedExpr -> [GHC.RdrName] -> Bool +#if __GLASGOW_HASKELL__ <= 710 +isJustBoundVar (GHC.HsVar nm) names = elem nm names +#else +isJustBoundVar (GHC.HsVar (GHC.L _ nm)) names = elem nm names +#endif +isJustBoundVar _ _ = False + +getDoStmts :: GHC.HsBind GHC.RdrName -> Maybe [GHC.ExprLStmt GHC.RdrName] +getDoStmts funBind = SYB.something (Nothing `SYB.mkQ` stmtLst) funBind + where stmtLst :: GHC.HsExpr GHC.RdrName -> Maybe [GHC.ExprLStmt GHC.RdrName] +#if __GLASGOW_HASKELL__ <= 710 + stmtLst (GHC.HsDo _ stmtLst _) = Just (init stmtLst) +#else + stmtLst (GHC.HsDo _ (GHC.L _ stmtLst) _) = Just (init stmtLst) +#endif + stmtLst _ = Nothing + +findBoundVars :: [GHC.ExprLStmt GHC.RdrName] -> [GHC.RdrName] +findBoundVars = SYB.everything (++) ([] `SYB.mkQ` findVarPats) + where findVarPats :: GHC.Pat GHC.RdrName -> [GHC.RdrName] +#if __GLASGOW_HASKELL__ <= 710 + findVarPats (GHC.VarPat rdr) = [rdr] +#else + findVarPats (GHC.VarPat (GHC.L _ rdr)) = [rdr] +#endif + findVarPats _ = [] + +getReturnRhs :: UnlocParsedHsBind -> Maybe ParsedExpr +getReturnRhs funBind = SYB.something (Nothing `SYB.mkQ` retStmt `SYB.extQ` dollarRet) funBind + where retStmt :: GHC.ExprLStmt GHC.RdrName -> Maybe ParsedExpr + retStmt (GHC.L _ (GHC.BodyStmt (GHC.L _ body) _ _ _)) = if isRet body + then Just (retRHS body) + else Nothing + retStmt _ = Nothing + dollarRet :: ParsedExpr -> Maybe ParsedExpr + dollarRet (GHC.OpApp ret dollar _ expr) = if (isHsVar "return" $ GHC.unLoc ret) && (isHsVar "$" $ GHC.unLoc dollar) + then Just (GHC.unLoc expr) + else Nothing + dollarRet _ = Nothing + isRet :: ParsedExpr -> Bool + isRet (GHC.HsApp (GHC.L _ mRet) _) = isHsVar "return" mRet + isRet _ = False + retRHS :: ParsedExpr -> ParsedExpr + retRHS (GHC.HsApp _ (GHC.L _ rhs)) = rhs + +constructAppChain :: ParsedExpr -> [GHC.ExprLStmt GHC.RdrName] -> RefactGhc ParsedLExpr +constructAppChain retRhs lst = do + let clusters = clusterStmts lst + boundVars = findBoundVars lst + pars <- mapM buildSingleExpr clusters + pars2 <- if length pars == 1 + then do newP <- (removePars (head pars)) + return [newP] + else return pars + effects <- buildChain pars2 + mPure <- processReturnStatement retRhs boundVars + case mPure of + Nothing -> do + return effects + (Just pure) -> do + setDP (DP (0,1)) pure + lOp <- lInfixFmap + addAnnVal lOp + locate (GHC.OpApp pure lOp GHC.PlaceHolder effects) + where + buildChain :: [ParsedLExpr] -> RefactGhc ParsedLExpr + buildChain [e] = return e + buildChain (e:es) = do + rhs <- buildChain es + lOp <- lFApp + addAnnVal lOp + let opApp = (GHC.OpApp e lOp GHC.PlaceHolder rhs) + locate opApp + getStmtExpr :: GHC.ExprLStmt GHC.RdrName -> ParsedLExpr + getStmtExpr (GHC.L _ (GHC.BodyStmt body _ _ _)) = body +#if __GLASGOW_HASKELL__ <= 710 + getStmtExpr (GHC.L _ (GHC.BindStmt _ body _ _)) = body +#else + getStmtExpr (GHC.L _ (GHC.BindStmt _ body _ _ _)) = body +#endif + buildSingleExpr :: [GHC.ExprLStmt GHC.RdrName] -> RefactGhc ParsedLExpr + buildSingleExpr [st] = return $ getStmtExpr st + buildSingleExpr lst@(st:stmts) = do + let (before,(bindSt:after)) = break isBindStmt lst + rOp <- rApp + lOp <- lApp + mLeftOfBnds <- buildApps rOp (map getStmtExpr before) + mRightOfBnds <- buildApps lOp (map getStmtExpr after) + mapM_ (\ex -> (setDP (DP (0,1))) (getStmtExpr ex)) (tail lst) + lROp <- lRApp + addAnnVal lROp + lLOp <- lLApp + addAnnVal lLOp + newBndStmt <- mkBind (getStmtExpr bindSt) + case (mLeftOfBnds,mRightOfBnds) of + (Nothing,Nothing) -> error "buildSingleExpr was passed an empty list." + ((Just leftOfBnds),Nothing) -> do + app <- locate (GHC.OpApp leftOfBnds lROp GHC.PlaceHolder newBndStmt) + wrapInPars app + (Nothing, (Just rightOfBnds)) -> do + app <- locate (GHC.OpApp newBndStmt lLOp GHC.PlaceHolder rightOfBnds) + wrapInPars app + ((Just leftOfBnds),(Just rightOfBnds)) -> do + setDP (DP (0,1)) newBndStmt + lOpApp <- locate (GHC.OpApp leftOfBnds lROp GHC.PlaceHolder newBndStmt) + fullApp <- locate (GHC.OpApp lOpApp lLOp GHC.PlaceHolder rightOfBnds) + wrapInPars fullApp + mkBind :: ParsedLExpr -> RefactGhc ParsedLExpr + mkBind e@(GHC.L _ (GHC.HsVar _)) = return e + mkBind expr = do + zeroDP expr + wrapInParsWithDPs (DP (0,0)) (DP (0,0)) expr + buildApps :: ParsedExpr -> [ParsedLExpr] -> RefactGhc (Maybe ParsedLExpr) + buildApps op [] = return Nothing + buildApps op [st] = return (Just st) + buildApps op (st:stmts) = do + mRhs <- buildApps op stmts + case mRhs of + Nothing -> return (Just st) + (Just rhs) -> do + lOp <- locate op + addAnnVal lOp + lExpr <- locate (GHC.OpApp st lOp GHC.PlaceHolder rhs) + return (Just lExpr) + clusterStmts :: [GHC.ExprLStmt GHC.RdrName] -> [[GHC.ExprLStmt GHC.RdrName]] + clusterStmts lst = let indices = findIndices isBindStmt lst + clusters = cluster indices (length lst) 0 in + map (\is -> map (\i -> lst !! i) is) clusters + cluster [i] l c = [[c..(l-1)]] + cluster (i1:i2:is) l c = let b = i1 + ((i2-i1) `div` 2) in + [c .. b]:(cluster (i2:is) l (b+1)) + +--Checks if a name occurs in the given ast chunk +nameOccurs :: Data a => GHC.RdrName -> a -> Bool +nameOccurs nm = SYB.everything (||) (False `SYB.mkQ` isName) + where isName :: GHC.RdrName -> Bool + isName mName = nm == mName + +isBindStmt :: GHC.ExprLStmt GHC.RdrName -> Bool +#if __GLASGOW_HASKELL__ <= 710 +isBindStmt (GHC.L _ (GHC.BindStmt _ _ _ _)) = True +#else +isBindStmt (GHC.L _ (GHC.BindStmt _ _ _ _ _)) = True +#endif +isBindStmt _ = False + +lFApp :: RefactGhc ParsedLExpr +lFApp = fApp >>= locate + +fApp :: RefactGhc ParsedExpr +fApp = hsVar "<*>" + + +isFApp :: ParsedLExpr -> Bool +#if __GLASGOW_HASKELL__ <= 710 +isFApp (GHC.L _ (GHC.HsVar rdrNm)) = (GHC.mkVarUnqual (fsLit "<*>")) == rdrNm +#else +isFApp (GHC.L _ (GHC.HsVar (GHC.L _ rdrNm))) = (GHC.mkVarUnqual (fsLit "<*>")) == rdrNm +#endif +isFApp _ = False + +lLApp :: RefactGhc ParsedLExpr +lLApp = lApp >>= locate + +lApp :: RefactGhc ParsedExpr +lApp = hsVar "<*" + +lRApp :: RefactGhc ParsedLExpr +lRApp = rApp >>= locate + +rApp :: RefactGhc ParsedExpr +rApp = hsVar "*>" + +lInfixFmap :: RefactGhc ParsedLExpr +lInfixFmap = infixFmap >>= locate + +infixFmap :: RefactGhc ParsedExpr +infixFmap = hsVar "<$>" + +-- TODO: Move this to Utils/Variables.hs, but make it lhsVar +hsVar :: String -> RefactGhc ParsedExpr +hsVar n = do +#if __GLASGOW_HASKELL__ <= 710 + return (GHC.HsVar (mkRdrName n)) +#else + lNm <- locate $ mkRdrName n + liftT $ addSimpleAnnT lNm (DP (0,0)) [(G GHC.AnnVal,DP (0,0))] + return (GHC.HsVar lNm) +#endif diff --git a/src/Language/Haskell/Refact/Refactoring/MoveDef.hs b/src/Language/Haskell/Refact/Refactoring/MoveDef.hs --- a/src/Language/Haskell/Refact/Refactoring/MoveDef.hs +++ b/src/Language/Haskell/Refact/Refactoring/MoveDef.hs @@ -90,6 +90,7 @@ -> RefactGhc [ApplyRefacResult] compLiftToTopLevel fileName (row,col) = do parseSourceFileGhc fileName + logParsedSource "liftToMod orig:" parsed <- getRefactParsed nm <- getRefactNameMap @@ -131,7 +132,7 @@ mod -- the scoped abstract syntax tree of the module. pn -- the function/pattern name to be lifted. -} -liftToTopLevel' :: GHC.ModuleName -- -> (ParseResult,[PosToken]) -> FilePath +liftToTopLevel' :: GHC.ModuleName -> GHC.Located GHC.Name -> RefactGhc [ApplyRefacResult] liftToTopLevel' modName pn@(GHC.L _ n) = do @@ -167,7 +168,7 @@ parsed' <- getRefactParsed parsed <- liftT $ balanceAllComments parsed' nm <- getRefactNameMap - logDataWithAnns "parsed after balanceAllComments" parsed + -- logDataWithAnns "parsed after balanceAllComments" parsed declsp <- liftT $ hsDecls parsed (before,parent,after) <- divideDecls declsp pn {- ++AZ++TODO: reinstate this, hsDecls does : hsBinds does not return class or instance definitions @@ -176,14 +177,20 @@ when (isInstDecl $ ghead "liftToMod" parent) $ error "Sorry, the refactorer cannot lift a definition from an instance declaration!" -} - nameMap <- getRefactNameMap -- declsParent <- liftT $ hsDecls (ghead "liftToMod" parent) -- logm $ "liftToMod:(declsParent)=" ++ (showGhc declsParent) - let liftedDecls = definingDeclsRdrNames nameMap [n] parent True True - declaredPns = nub $ concatMap (definedNamesRdr nameMap) liftedDecls - liftedSigs = definingSigsRdrNames nameMap declaredPns parent + let liftedDecls = definingDeclsRdrNames nm [n] parent True True + declaredPns = nub $ concatMap (definedNamesRdr nm) liftedDecls + liftedSigs = definingSigsRdrNames nm declaredPns parent mLiftedSigs = liftedSigs + + -- logDataWithAnns "liftedDecls" liftedDecls + + -- Check that the lifted declaration does not include a tuple pattern on the lhs + when (any isTupleDecl liftedDecls) $ do + error "Cannot lift a declaration assigning to a tuple pattern" + -- TODO: what about declarations between this -- one and the top level that are used in this one? @@ -194,21 +201,26 @@ let dd = getDeclaredVarsRdr nm decls logm $ "liftToMod:(ddd)=" ++ (showGhc dd) - if pns == [] + if null pns then do (parent',liftedDecls',mLiftedSigs') <- addParamsToParentAndLiftedDecl n dd parent liftedDecls mLiftedSigs - let defName = (ghead "liftToMod" (definedNamesRdr nameMap (ghead "liftToMod2" parent'))) + let defName = ghead "liftToMod" (definedNamesRdr nm (ghead "liftToMod2" parent')) parsed1 <- liftT $ replaceDecls parsed (before++parent'++after) parsed2 <- moveDecl1 parsed1 (Just defName) [GHC.unLoc pn] liftedDecls' declaredPns mLiftedSigs' putRefactParsed parsed2 emptyAnns + logParsedSource "liftToMod done:" + return declaredPns else askRenamingMsg pns "lifting" - +isTupleDecl :: GHC.LHsDecl GHC.RdrName -> Bool +isTupleDecl (GHC.L _ (GHC.ValD (GHC.PatBind (GHC.L _ GHC.TuplePat {}) _ _ _ _))) = True +isTupleDecl (GHC.L _ (GHC.ValD (GHC.PatBind (GHC.L _ (GHC.AsPat _ (GHC.L _ GHC.TuplePat {}))) _ _ _ _))) = True +isTupleDecl _ = False -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Refactoring/Renaming.hs b/src/Language/Haskell/Refact/Refactoring/Renaming.hs --- a/src/Language/Haskell/Refact/Refactoring/Renaming.hs +++ b/src/Language/Haskell/Refact/Refactoring/Renaming.hs @@ -1,21 +1,32 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.Refact.Refactoring.Renaming ( rename , compRename ) where +import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB import qualified GHC import qualified Name as GHC +-- import qualified OccName as GHC +import qualified Outputable as GHC import qualified RdrName as GHC import Control.Monad +import Data.Generics.Strafunski.StrategyLib.StrategyLib hiding (liftIO,MonadPlus,mzero) import Data.List - -import qualified Language.Haskell.GhcMod as GM (Options(..)) +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.Refact.API import System.Directory +import qualified Language.Haskell.GhcMod as GM (Options(..)) +import qualified Data.Map as Map +{-# ANN module "HLint: ignore Redunant do" #-} +{-# ANN module "HLint: ignore Eta reduce" #-} + {-This refactoring renames an indentifier to a user-specified name. Conditions: @@ -69,41 +80,32 @@ -- logDataWithAnns "parsed" parsed let modName = maybe (GHC.mkModuleName "Main") fst $ getModuleName parsed - maybePn = locToRdrName (row, col) parsed - logm $ "Renamed.comp:maybePn=" ++ showGhc maybePn -- ++AZ++ - - case maybePn of - Just pn'@(GHC.L l _) -> do + case locToRdrName (row, col) parsed of + Just pn'@(GHC.L l rdrName) -> do let n = rdrName2NamePure nm pn' pn = GHC.L l n logm $ "Renaming:(n,modu)=" ++ showGhc (n,modu) - let (GHC.L _ rdrName) = gfromJust "Renaming.comp.2" $ locToRdrName (row, col) parsed - let rdrNameStr = GHC.occNameString $ GHC.rdrNameOcc rdrName - logm $ "Renaming: rdrName=" ++ SYB.showData SYB.Parser 0 rdrName - logm $ "Renaming: occname rdrName=" ++ show (GHC.occNameString $ GHC.rdrNameOcc rdrName) + let occName = GHC.rdrNameOcc rdrName + let rdrNameStr = GHC.occNameString occName + logm $ "Renaming:original occName attributes:" ++ showGhc occName ++ occAttributes occName + unless (nameToString n /= newName) $ error "The new name is same as the old name" unless (isValidNewName n rdrNameStr newName) $ error $ "Invalid new name:" ++ newName ++ "!" - - logm $ "Renaming.comp: before GHC.nameModule,n=" ++ showGhc n - let defineMod = case GHC.nameModule_maybe n of Just mn -> GHC.moduleName mn Nothing -> modName - -- TODO: why do we have this restriction? unless (defineMod == modName) . error $ mconcat [ "This identifier is defined in module " , GHC.moduleNameString defineMod , ", please do renaming in that module!" ] - logm $ "Renaming.comp:(isMainModule modu,pn)=" ++ showGhcQual (isMainModule modu,pn) when (isMainModule modu && showGhcQual pn == "Main.main") $ error "The 'main' function defined in a 'Main' module should not be renamed!" - logm "Renaming.comp: not main module" newNameGhc <- mkNewGhcName (Just modu) newName (refactoredMod, nIsExported) <- applyRefac (doRenaming pn rdrNameStr newName newNameGhc modName) RSAlreadyLoaded @@ -118,78 +120,348 @@ Nothing -> error "Invalid cursor position!" +-- --------------------------------------------------------------------- + +condChecking :: (SYB.Data t) + => GHC.Name -> String -> GHC.Name -> GHC.ModuleName + -> t + -> Bool -> Bool -> RefactGhc () +condChecking oldPN newName newNameGhc modName ast existChecking exportChecking = do + condChecking1 oldPN newName newNameGhc modName ast existChecking exportChecking + nm <- getRefactNameMap + condChecking2 nm oldPN newName ast + +-- --------------------------------------------------------------------- + -- |Actually do the renaming, split into the various things that can -- be renamed. Returns True if the name is exported doRenaming :: GHC.Located GHC.Name -> String -> String -> GHC.Name -> GHC.ModuleName -> RefactGhc Bool --------Rename a value variable name-------------------------------- doRenaming pn@(GHC.L _ oldn) rdrNameStr newNameStr newNameGhc modName = do - logm $ "doRenaming:(pn,rdrNameStr,newNameStr) = " ++ showGhc (pn,rdrNameStr,newNameStr) - renameTopLevelVarName oldn newNameStr newNameGhc modName True True - logm "doRenaming done" - isExported oldn - -renameTopLevelVarName :: GHC.Name -> String -> GHC.Name -> GHC.ModuleName - -> Bool -> Bool -> RefactGhc () -renameTopLevelVarName oldPN newName newNameGhc modName existChecking exportChecking = do - logm $ "renameTopLevelVarName:(existChecking, exportChecking)=" ++ show (existChecking, exportChecking) - causeAmbiguity <- causeAmbiguityInExports oldPN newNameGhc + logm $ "doRenaming:(pn,rdrNameStr,newNameStr) = (" ++ intercalate "," [showGhc pn,rdrNameStr,newNameStr] ++ ")" parsed <- getRefactParsed nm <- getRefactNameMap + + if GHC.isVarName oldn + then do + decls <- liftT $ hsDeclsGeneric parsed + if isDeclaredInRdr nm oldn decls + then do + logm "doRenaming:renameInMod isDeclaredInRdr True" + condChecking oldn newNameStr newNameGhc modName parsed True True + parsed' <- renameTopLevelVarName oldn newNameStr newNameGhc True + putRefactParsed parsed' mempty + isExported oldn + else do + logm "doRenaming: not declared at the top level" + condChecking oldn newNameStr newNameGhc modName parsed False False + parsed' <- renameTopLevelVarName oldn newNameStr newNameGhc False + putRefactParsed parsed' mempty + return False -- Not exported + else do + logm "doRenaming:not isVarName" + condChecking oldn newNameStr newNameGhc modName parsed True True + parsed' <- renameTopLevelVarName oldn newNameStr newNameGhc True + putRefactParsed parsed' mempty + isExported oldn + +-- --------------------------------------------------------------------- +{- +From Huiqing Li thesis + +p 75 + +The second part is defined in the local function condChecking2. This function +performs a top-down traversal of the AST until it reaches a syntax entity, say +E, such that E contains the declaration of x , and all the references to the x +in question. E could be the Haskell module, a declaration defining a function, a +declaration defining a pattern binding, an expression, a branch in a +case-expression, or a do statement. The syntax phrase E forms the context for +condition checking, and at the place where it is reached, the function +condChecking' is called, and the traversal terminates. + +Inside the function condChecking' , three conditions are checked. + + - The first condition ensures that the new name does not exist in the same + binding group, where the function declaredVarsInSameGroup (from the API) is + used to fetch all the variable names declared in the same binding group + where x [AZ: The old name] is declared. + + - The second condition checks whether the new name will intervene between the + existing uses of y [AZ: the new name] and its bindings, where function + hsFreeAndDeclaredNames is used to fetch the free and declared variables in + the argument syntax phrase. + + - The third condition checks whether the new name is declared somewhere + between the declaration of identifier to be renamed and one of its + call-sites, and function hsVisibleNames is used to collect the names which + are declared in the given syntax phrase and visible to one of the call-sites + of the identifier. + +In the local functions, including inMatch, inPattern, and inAlt , the values +defaultPNT and/or [ ] are used to shadow those variables declared in the same +syntax phrase but in an outer scope. + +-} + +-- |Some non-trivial condition checking. +-- Returns on success, throws an error on check failure +condChecking2 :: (SYB.Data t) => NameMap -> GHC.Name -> String -> t -> RefactGhc () +condChecking2 nm oldPN newName t = do + void $ applyTP (once_buTP (failTP `adhocTP` inMod + `adhocTP` inMatch + `adhocTP` inExp + `adhocTP` inStmts + `adhocTP` inDataDefn + `adhocTP` inConDecl + `adhocTP` inTyClDecl + )) t + where + -- return True if oldPN is declared by t. + isDeclaredBy t = isDeclaredBy' t + where + isDeclaredBy' t + = do (_ , d) <- hsFreeAndDeclaredPNs t + -- logDataWithAnns "isDeclaredBy:t" t + logm $ "isDeclaredBy:d=" ++ showGhc d + return (oldPN `elem` d ) + + -- The name is a top-level identifier + inMod (parsed :: GHC.ParsedSource) = do + decls <- liftT $ hsDeclsGeneric parsed + isDeclared <- isDeclaredBy decls + logm $ "Renaming.condChecking2.inMod:isDeclared=" ++ show isDeclared + if isDeclared + then condChecking' parsed + else mzero + + -- The name is declared in a function definition. +#if __GLASGOW_HASKELL__ <= 710 + inMatch (GHC.Match f@(Just (ln,_)) pats mtype (GHC.GRHSs rhs ds) + ::GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do +#else + inMatch (GHC.Match f@(GHC.FunBindMatch ln isInfix) pats mtype (GHC.GRHSs rhs ds) + ::GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do +#endif + isDeclaredPats <- isDeclaredBy pats + isDeclaredDs <- isDeclaredBy ds + logm $ "Renaming.condChecking2.inMatch:isDeclared=" ++ show (isDeclaredPats,isDeclaredDs) + if isDeclaredPats + then condChecking' (GHC.Match f pats mtype (GHC.GRHSs rhs ds)) + else if isDeclaredDs + then condChecking' (GHC.Match f [] mtype (GHC.GRHSs rhs ds)) + else mzero + inMatch _ = mzero + + -- The name is declared in a expression. + inExp expr@((GHC.L _ (GHC.HsLet ds e)):: GHC.LHsExpr GHC.RdrName) = do + isDeclaredDs <- isDeclaredBy ds + -- logm $ "inExp.HsLet:isDeclaredDs=" ++ show isDeclaredDs + if isDeclaredDs + then condChecking' expr + else mzero + inExp expr@((GHC.L _ (GHC.HsDo _ ds e)):: GHC.LHsExpr GHC.RdrName) = do + isDeclared <- isDeclaredBy ds + -- logDataWithAnns "inExp.HsDo:expr" expr + logm $ "inExp.HsDo:isDeclared=" ++ show isDeclared + if isDeclared + then condChecking' expr + else mzero + inExp _ = mzero +{- + -- The name is declared in a expression. + inExp (exp@(Exp (HsLambda pats body))::HsExpP) + |isDeclaredBy pats + = condChecking' exp + inExp (exp@(Exp (HsLet ds e)):: HsExpP) + |isDeclaredBy ds + = condChecking' exp + inExp _ = mzero + + -- The name is declared in a case alternative. + inAlt (alt@(HsAlt loc p rhs ds)::HsAltP) + |isDeclaredBy p + = condChecking' alt + |isDeclaredBy ds + = condChecking' (HsAlt loc defaultPat rhs ds) + |otherwise = mzero + +-} + + inStmts (stmt@(GHC.L _ (GHC.LetStmt binds)) :: GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do + isDeclared <- isDeclaredBy binds + if isDeclared + then condChecking' stmt + else mzero + inStmts _ = mzero + + inDataDefn dd@(GHC.HsDataDefn _ ctxt mctype mkindsig cons derivs :: GHC.HsDataDefn GHC.RdrName) = do + declared <- isDeclaredBy cons + if declared + then condChecking' dd + else mzero + + -- The name is declared in a ConDecl +#if __GLASGOW_HASKELL__ <= 710 + inConDecl (cd@(GHC.ConDecl ns _expr (GHC.HsQTvs _ns bndrs) ctxt + dets res _ depc_syntax) :: GHC.ConDecl GHC.RdrName ) = + case res of + GHC.ResTyGADT ls typ -> do + declared <- isDeclaredBy ns + if declared + then condChecking' cd + else mzero + GHC.ResTyH98 -> do + declaredn <- isDeclaredBy ns + declaredd <- isDeclaredBy dets + if declaredn || declaredd + then condChecking' cd + else mzero +#else + inConDecl cd@(GHC.ConDeclGADT ns _ _ :: GHC.ConDecl GHC.RdrName) = do + declared <- isDeclaredBy ns + -- TODO: what about condChecking' ? + if declared + then condChecking' cd + else mzero + inConDecl cd@(GHC.ConDeclH98 n _ _ dets _) = do + declaredn <- isDeclaredBy n + declaredd <- isDeclaredBy dets + if declaredn || declaredd + then condChecking' cd + else mzero +#endif + + +#if __GLASGOW_HASKELL__ <= 710 + inTyClDecl dd@(GHC.DataDecl ln (GHC.HsQTvs _ns tyvars) defn _ :: GHC.TyClDecl GHC.RdrName) = do +#else + inTyClDecl dd@(GHC.DataDecl ln tyvars defn _ _ :: GHC.TyClDecl GHC.RdrName) = do +#endif + declared <- isDeclaredBy dd + declaredtv <- isDeclaredBy tyvars + -- logm $ "condChecking2:inTyClDecl:(declared,declaredtv)=" ++ show (declared,declaredtv) + if declared || declaredtv + then condChecking' dd + else mzero + inTyClDecl _ = mzero + + -- --------------------------------- + + condChecking' t = do + sameGroupDecls <- declaredVarsInSameGroup nm oldPN t + -- logm $ "condChecking':sameGroupDecls=" ++ showGhc sameGroupDecls + when (newName `elem` sameGroupDecls) + $ error "The new name exists in the same binding group!" + (f, d) <- hsFreeAndDeclaredNameStrings t + when (newName `elem` f) $ error "Existing uses of the new name will be captured!" + -- fetch all the declared variables in t that + -- are visible to the places where oldPN occurs. + ds <- hsVisibleNamesRdr oldPN t + -- logm $ "Renaming.condChecking':t=" ++ showGhc t + -- logm $ "Renaming.condChecking':ds=" ++ showGhc ds + when (newName `elem` ds) $ error "The new name will cause name capture!" + return t + +declaredVarsInSameGroup :: (SYB.Data t) => NameMap -> GHC.Name -> t -> RefactGhc [String] +declaredVarsInSameGroup nm n t = do + -- simplification: we know we are doing a bottom-up process, stopping where + -- the name is first declared. Hence the declaration has to be at the current + -- level of @t@ + decls <- liftT $ hsDeclsGeneric t + let declared = nub $ map showGhc $ getDeclaredVarsRdr nm decls + return $ filter (/= showGhc n) declared + + +-- --------------------------------------------------------------------- + +condChecking1 :: (SYB.Data t) + => GHC.Name -> String -> GHC.Name -> GHC.ModuleName + -> t + -> Bool -> Bool -> RefactGhc () +condChecking1 oldPN newName newNameGhc modName ast existChecking exportChecking = do + -- logm $ "condChecking1:(existChecking, exportChecking)=" ++ show (existChecking, exportChecking) + -- parsed <- getRefactParsed + nm <- getRefactNameMap -- f' contains names imported from other modules; -- d' contains the top level names declared in this module; - let (FN f', DN d') = hsFDsFromInsideRdr nm parsed + let (FN f', DN d') = hsFDsFromInsideRdr nm ast --filter those qualified free variables in f' - -- let (f,d) = ((nub.map pNtoName.filter (not.isQualifiedPN)) f', (nub.map pNtoName) d') - let (f, d) = (map nameToString f', map nameToString d') - logm $ "renameTopLevelVarName:f=" ++ show f - logm $ "renameTopLevelVarName:d=" ++ show d + let (f, _d) = (map nameToString f', map nameToString d') let newNameStr = nameToString newNameGhc - logm $ "renameTopLevelVarName:(newName,newNameStr)=" ++ show (newName, newNameStr) scopeClashNames <- inScopeNames newName - logm $ "renameTopLevelVarName:(f')=" ++ showGhc f' - logm $ "renameTopLevelVarName:(scopeClashNames,intersection)=" ++ - showGhc (scopeClashNames, scopeClashNames `intersect` f') - logm $ "renameTopLevelVarName:(oldPN,modName)=" ++ showGhc (oldPN,modName) - -- Another implementation option is to add the qualifier to newName automatically. when (nonEmptyList $ intersect scopeClashNames f') . error $ mconcat [ "The new name will cause an ambiguous occurrence problem, " , "please select another new name or qualify the use of '" , newName ++ "' before renaming!\n"] - when (existChecking && newNameStr `elem` d \\ [nameToString oldPN]) . -- only check the declared names here - --the same name has been declared in this module. - error $ mconcat ["Name '", newName, "' already exists in this module\n"] + parsed <- getRefactParsed + let dns = map nameToString $ filter (sameNameSpace oldPN) d' + -- only check the declared names here + when (existChecking && newNameStr `elem` dns \\ [nameToString oldPN]) $ do + logm $ "condChecking1:dns=" ++ intercalate "," dns + let m = Map.fromList $ map (\n -> (nameToString n,n)) $ filter (sameNameSpace oldPN) d' + Just dupN = Map.lookup newNameStr m + logm $ "condChecking1:dupN=" ++ showGhcQual dupN + case definingTyClDeclsNames nm [dupN] parsed of + [] -> do + --the same name has been declared in this module. + error $ mconcat ["Name '", newName, "' already exists in this module\n"] + ds -> do + -- TODO: Check that we do not in fact have a name clash. It is only + -- safe if we are changing a field name where the name clashes with + -- a field name in another constructor + return () + when (exportChecking && causeNameClashInExports nm oldPN newNameGhc modName parsed) $ error "The new name will cause conflicting exports, please select another new name!" + + causeAmbiguity <- causeAmbiguityInExports oldPN newNameGhc when (exportChecking && causeAmbiguity) . -- causeAmbiguityInExports oldPN newNameGhc {- inscps -} renamed error $ mconcat ["The new name will cause ambiguity in the exports of module '" , show modName , "' , please select another name!"] - -- get all of those declared names visible to oldPN at where oldPN is used. - logm "renameTopLevelVarName:basic tests done" - - isInScopeUnqual <- isInScopeAndUnqualifiedGhc newName (Just newNameGhc) - logm "renameTopLevelVarName:after isInScopeUnqual" - logm $ "renameTopLevelVarName:oldPN=" ++ showGhc oldPN - ds <- hsVisibleNamesRdr oldPN parsed - logm $ "renameTopLevelVarName:ds computed=" ++ show ds - when (existChecking && newName `elem` nub (ds `union` f) \\ [nameToString oldPN]) . + DN ds' <- hsVisibleDsRdr nm oldPN ast + let dns2 = map nameToString $ filter (sameNameSpace oldPN) ds' + when (existChecking && newName `elem` nub (dns2 `union` f) \\ [nameToString oldPN]) . error $ mconcat [ "Name '", newName, "' already exists, or renaming '", nameToString oldPN, "' to '" , newName, "' will change the program's semantics!\n"] - logm "renameTopLevelVarName start..:should have qualified" - let qual = if (exportChecking && isInScopeUnqual) then Qualify else PreserveQualify - parsed' <- renamePN oldPN newNameGhc qual parsed - putRefactParsed parsed' mempty - logm "renameTopLevelVarName done:should have qualified" +-- --------------------------------------------------------------------- +renameTopLevelVarName :: GHC.Name -> String -> GHC.Name + -> Bool -> RefactGhc GHC.ParsedSource +renameTopLevelVarName oldPN newName newNameGhc exportChecking = do + parsed <- getRefactParsed + isInScopeUnqual <- isInScopeAndUnqualifiedGhc newName (Just newNameGhc) + let qual = if exportChecking && isInScopeUnqual then Qualify else PreserveQualify + renamePN oldPN newNameGhc qual parsed + +-- --------------------------------------------------------------------- + +renameLocalVarName :: (SYB.Data t) => GHC.Name -> String -> GHC.Name -> t -> RefactGhc t +renameLocalVarName oldPN newName newNameGhc t = do + nm <- getRefactNameMap + let qual = PreserveQualify + (f,d) <- hsFDNamesFromInsideRdr t + if elem newName (d \\ [showGhc oldPN]) --only check the declared names here. + then error ("Name '"++newName++"' already existed\n") + else do -- get all of those declared names visible to oldPN at where oldPN is used. + ds <- hsVisibleNamesRdr oldPN t + -- '\\[pNtoName oldPN]' handles the case in which the new name is same as the old name + if elem newName ((nub (ds `union` f)) \\[showGhc oldPN]) + then error ("Name '"++newName++"' already existed, or rename '" + ++showGhc oldPN++ "' to '"++newName++ + "' will change the program's semantics!\n") + else renamePN oldPN newNameGhc qual t + ------------------------------------------------------------------------ renameInClientMod :: GHC.Name -> String -> GHC.Name -> TargetModule @@ -206,27 +478,19 @@ -- We need to find the old name in the module, and get it as a -- GHC.Name to know what to look for in the call to renamePN', as it -- checks the GHC.nameUnique value. - -- gnames <- GHC.getNamesInScope - -- let clientModule = GHC.nameModule oldPN - -- let clientInscopes = filter (\n -> clientModule == GHC.nameModule n) gnames - -- logm $ "renameInClientMod:(clientInscopes)=" ++ showGhcQual (clientInscopes) - -- let newNames = filter (\n -> showGhcQual n == showGhcQual oldPN) clientInscopes newNames <- equivalentNameInNewMod oldPN logm $ "renameInClientMod:(newNames)=" ++ showGhcQual newNames - -- newNames <- inScopeNames (showGhcQual oldPN) - -- newNamesUnqual <- inScopeNames (showGhc oldPN) - -- logm $ "renameInClientMod:(newNamesUnqual,oldPN)=" ++ showGhcQual (newNamesUnqual,oldPN) - -- logm $ "renameInClientMod:(newNames,oldPN)=" ++ showGhcQual (newNames,oldPN) - -- logm $ "renameInClientMod:(uniques:newNames,oldPN)=" ++ showGhcQual (map GHC.nameUnique newNames,GHC.nameUnique oldPN) - case newNames of + let newNames' = filter (sameNameSpace oldPN) newNames + case newNames' of [] -> return [] - -- [oldName] | findPN oldName renamed -> doRenameInClientMod oldName modName renamed [oldName] | findNameInRdr nm oldName parsed -> doRenameInClientMod nm oldName modName parsed | otherwise -> do logm "renameInClientMod: name not present in module, returning" return [] - ns -> error $ "HaRe: renameInClientMod: could not find name to replace, got:" ++ showGhcQual ns + -- ns -> error $ "HaRe: renameInClientMod: could not find name to replace, got:" ++ showGhcQual ns + ns -> error $ "HaRe: renameInClientMod: could not find name to replace, got:" + ++ (showGhcQual $ map (\n -> (n,GHC.occNameSpace $ GHC.nameOccName n)) ns) where doRenameInClientMod nm oldNameGhc modName parsed = do @@ -242,7 +506,6 @@ if isInScopeUnqualNew -- ++AZ++: should this be negated? then do - -- (refactoredMod, _) <- applyRefac (refactRenameSimple oldNameGhc newName newNameGhc True) (refactoredMod, _) <- applyRefac (refactRenameSimple oldNameGhc newName newNameGhc Qualify) RSAlreadyLoaded return [refactoredMod] @@ -250,7 +513,6 @@ when (causeNameClashInExports nm oldPN newNameGhc modName parsed) . error $ mconcat [ "The new name will cause conflicting exports in module" , show newName, ", please select another name!"] - -- (refactoredMod,_) <- applyRefac (refactRenameComplex oldPN newName newNameGhc) RSAlreadyLoaded (refactoredMod, _) <- applyRefac (refactRenameComplex oldNameGhc newName newNameGhc) RSAlreadyLoaded -- TODO: implement rest of this @@ -295,6 +557,8 @@ putRefactParsed parsed mempty return () +-- --------------------------------------------------------------------- + causeAmbiguityInExports :: GHC.Name -> GHC.Name -> RefactGhc Bool causeAmbiguityInExports old newName {- inscps -} = do (GHC.L _ (GHC.HsModule _ exps _imps _decls _ _)) <- getRefactParsed @@ -302,6 +566,8 @@ let usedUnqual = usedWithoutQualR newName exps logm $ "causeAmbiguityInExports:(isInScopeUnqual,usedUnqual)" ++ show (isInScopeUnqual, usedUnqual) return (isInScopeUnqual && usedUnqual) + +-- --------------------------------------------------------------------- isValidNewName :: GHC.Name -> String -> String -> Bool isValidNewName oldName rdrNameStr newName = res diff --git a/src/Language/Haskell/Refact/Refactoring/Simple.hs b/src/Language/Haskell/Refact/Refactoring/Simple.hs --- a/src/Language/Haskell/Refact/Refactoring/Simple.hs +++ b/src/Language/Haskell/Refact/Refactoring/Simple.hs @@ -49,7 +49,7 @@ return s removePar e = return e p2 <- SYB.everywhereM (SYB.mkM removePar) parsed - (liftT getAnnsT) >>= putRefactParsed p2 + putRefactParsed p2 emptyAnns logm $ "logm: after refactor\n" ++ showGhc p2 -- EOF diff --git a/src/Language/Haskell/Refact/Utils/ExactPrint.hs b/src/Language/Haskell/Refact/Utils/ExactPrint.hs --- a/src/Language/Haskell/Refact/Utils/ExactPrint.hs +++ b/src/Language/Haskell/Refact/Utils/ExactPrint.hs @@ -12,20 +12,32 @@ , setAnnKeywordDP , clearPriorComments , balanceAllComments + , locate + , addEmptyAnn + , addAnnVal + , addAnn + , zeroDP + , setDP + , handleParseResult + , removeAnns + , synthesizeAnns + , addNewKeyword + , addNewKeywords ) where import qualified GHC as GHC import qualified Data.Generics as SYB - import Control.Monad import Language.Haskell.GHC.ExactPrint.Transform import Language.Haskell.GHC.ExactPrint.Types --- import Language.Haskell.GHC.ExactPrint.Utils - +import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.Refact.Utils.GhcUtils +import Language.Haskell.Refact.Utils.Monad +import Language.Haskell.Refact.Utils.MonadFunctions + import qualified Data.Map as Map -- --------------------------------------------------------------------- @@ -159,4 +171,109 @@ unless (null decls) $ moveTrailingComments t (last decls) return t --- --------------------------------------------------------------------- +--This generates a unique location and wraps the given ast chunk with that location +--Also adds an empty annotation at that location +locate :: (SYB.Data a) => a -> RefactGhc (GHC.Located a) +locate ast = do + loc <- liftT uniqueSrcSpanT + let res = (GHC.L loc ast) + addEmptyAnn res + return res + +--Adds an empty annotation at the provided location +addEmptyAnn :: (SYB.Data a) => GHC.Located a -> RefactGhc () +addEmptyAnn a = addAnn a annNone + +--Adds an "AnnVal" annotation at the provided location +addAnnVal :: (SYB.Data a) => GHC.Located a -> RefactGhc () +addAnnVal a = addAnn a valAnn + where valAnn = annNone {annEntryDelta = DP (0,1), annsDP = [(G GHC.AnnVal, DP (0,0))]} + +--Adds the given annotation at the provided location +addAnn :: (SYB.Data a) => GHC.Located a -> Annotation -> RefactGhc () +addAnn a ann = do + currAnns <- fetchAnnsFinal + let k = mkAnnKey a + setRefactAnns $ Map.insert k ann currAnns + +--Sets the entry delta position of an ast chunk +setDP :: (SYB.Data a) => DeltaPos -> GHC.Located a -> RefactGhc () +setDP dp ast = do + currAnns <- fetchAnnsFinal + let k = mkAnnKey ast + mv = Map.lookup k currAnns + case mv of + Nothing -> return () + Just v -> addAnn ast (v {annEntryDelta = dp}) + +--Resets the given AST chunk's delta position to zero. +zeroDP :: (SYB.Data a) => GHC.Located a -> RefactGhc () +zeroDP = setDP (DP (0,0)) + +--This just pulls out the successful result from an exact print parser or throws an error if the parse was unsuccessful. +handleParseResult :: String -> Either (GHC.SrcSpan, String) (Anns, a) -> RefactGhc (Anns, a) +handleParseResult msg e = case e of + (Left (_, errStr)) -> error $ "The parse from: " ++ msg ++ " with error: " ++ errStr + (Right res) -> return res + +-- This creates an empty annotation for every located item where an annotation does not already exist in the given AST chunk +synthesizeAnns :: (SYB.Data a) => a -> RefactGhc a +synthesizeAnns = generic `SYB.ext2M` located + where generic :: SYB.Data a => a -> RefactGhc a + generic a = do + _ <- SYB.gmapM synthesizeAnns a + return a + located :: (SYB.Data b, SYB.Data loc) => GHC.GenLocated loc b -> RefactGhc (GHC.GenLocated loc b) + located b@(GHC.L ss a) = case SYB.cast ss of + Just (s :: GHC.SrcSpan) -> do + --logm $ "Located found: " ++ (show $ toConstr a) + anns <- fetchAnnsFinal + let castRes = (GHC.L s a) + ann = getAnnotationEP castRes anns + --logm $ "Found ann: " ++ show ann + case ann of + Nothing -> do + --logm "No ann found for located item" + let newKey = mkAnnKey castRes + newAnns = Map.insert newKey annNone anns + setRefactAnns newAnns + return () + _ -> return () + _ <- SYB.gmapM synthesizeAnns b + return b + Nothing -> + return b + +-- This removes all the annotations associated with the given AST chunk. +removeAnns :: (SYB.Data a) => a -> RefactGhc a +removeAnns = generic `SYB.ext2M` located + where generic :: SYB.Data a => a -> RefactGhc a + generic a = do + _ <- SYB.gmapM synthesizeAnns a + return a + located :: (SYB.Data b, SYB.Data loc) => GHC.GenLocated loc b -> RefactGhc (GHC.GenLocated loc b) + located b@(GHC.L ss a) = case SYB.cast ss of + Just (s :: GHC.SrcSpan) -> do + anns <- fetchAnnsFinal + let k = mkAnnKey (GHC.L s a) + logm $ "Deleting ann at: " ++ (show s) + setRefactAnns $ Map.delete k anns + _ <- SYB.gmapM removeAnns b + return b + Nothing -> return b + +--This takes in a located ast chunk and adds the provided keyword and delta position into the annsDP list +--If there is not annotation associated with the chunk nothing happens +addNewKeyword :: (SYB.Data a) => (KeywordId, DeltaPos) -> GHC.Located a -> RefactGhc () +addNewKeyword entry a = do + anns <- liftT getAnnsT + let key = mkAnnKey a + mAnn = Map.lookup key anns + case mAnn of + Nothing -> return () + (Just ann) -> do + let newAnn = ann{annsDP = (entry:(annsDP ann))} + setRefactAnns $ Map.insert key newAnn anns + +addNewKeywords :: (SYB.Data a) => [(KeywordId, DeltaPos)] -> GHC.Located a -> RefactGhc () +addNewKeywords entries a = mapM_ ((flip addNewKeyword) a) entries diff --git a/src/Language/Haskell/Refact/Utils/GhcModuleGraph.hs b/src/Language/Haskell/Refact/Utils/GhcModuleGraph.hs --- a/src/Language/Haskell/Refact/Utils/GhcModuleGraph.hs +++ b/src/Language/Haskell/Refact/Utils/GhcModuleGraph.hs @@ -8,11 +8,10 @@ ) where -- GHC imports -#if __GLASGOW_HASKELL__ > 710 -import BasicTypes -#endif import Digraph +#if __GLASGOW_HASKELL__ <= 710 import FastString +#endif import GHC import HscTypes import Panic diff --git a/src/Language/Haskell/Refact/Utils/GhcUtils.hs b/src/Language/Haskell/Refact/Utils/GhcUtils.hs --- a/src/Language/Haskell/Refact/Utils/GhcUtils.hs +++ b/src/Language/Haskell/Refact/Utils/GhcUtils.hs @@ -20,7 +20,8 @@ , everywhereStaged , everywhereStaged' , listifyStaged - + , everywhereButM + -- ** SYB Utility -- , checkItemRenamer @@ -80,6 +81,16 @@ gmapM (everywhereM' f) x' -- --------------------------------------------------------------------- + +-- Monadic everywhereBut +-- Traversal ceases if q holds for x + +everywhereButM :: Monad m => SYB.GenericQ Bool -> SYB.Generic m -> SYB.GenericM m +everywhereButM q f x + | q x = return x + | otherwise = do + x' <- f x + gmapM (everywhereButM q f) x' -- | Bottom-up transformation everywhereStaged :: SYB.Stage -> (forall a. Data a => a -> a) -> forall a. Data a => a -> a 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 @@ -13,7 +13,8 @@ , ghcSpanStartEnd , getStartEndLoc , startEndLocGhc - , emptyList, nonEmptyList + , emptyList + , nonEmptyList ) where @@ -158,5 +159,3 @@ importDecl (GHC.L l _) = Just l -- --------------------------------------------------------------------- - - diff --git a/src/Language/Haskell/Refact/Utils/Monad.hs b/src/Language/Haskell/Refact/Utils/Monad.hs --- a/src/Language/Haskell/Refact/Utils/Monad.hs +++ b/src/Language/Haskell/Refact/Utils/Monad.hs @@ -51,6 +51,7 @@ import Exception import qualified Language.Haskell.GhcMod as GM import qualified Language.Haskell.GhcMod.Internal as GM +import qualified Language.Haskell.GhcMod.Monad.Out as GM import qualified Language.Haskell.GhcMod.Monad.Types as GM import Language.Haskell.Refact.Utils.Types import Language.Haskell.GHC.ExactPrint @@ -96,7 +97,7 @@ data RefactStashId = Stash !String deriving (Show,Eq,Ord) data RefactModule = RefMod - { rsTypecheckedMod :: !GHC.TypecheckedModule + { rsTypecheckedMod :: !TypecheckedModule , rsNameMap :: NameMap -- ^ Mapping from the names in the ParsedSource to the renamed -- versions. Note: No strict mark, can be computed lazily. @@ -166,7 +167,7 @@ -- |Result of parsing a Haskell source file. It is simply the -- TypeCheckedModule produced by GHC. -type ParseResult = GHC.TypecheckedModule +type ParseResult = TypecheckedModule -- |Provide some temporary storage while the refactoring is taking -- place @@ -216,7 +217,11 @@ -- --------------------------------------------------------------------- instance GM.GmOut (StateT RefactState IO) where + gmoAsk = lift GM.gmoAsk +instance GM.GmOut IO where + gmoAsk = GM.gmoAsk + instance GM.MonadIO (StateT RefactState IO) where liftIO = liftIO @@ -248,9 +253,13 @@ where doCabalModuleGraphs :: (GM.IOish m) => GM.GhcModT m [GM.GmModuleGraph] doCabalModuleGraphs = do - mcs <- GM.cabalResolvedComponents - let graph = map GM.gmcHomeModuleGraph $ Map.elems mcs - return $ graph + crdl <- GM.cradle + case GM.cradleCabalFile crdl of + Just _ -> do + mcs <- GM.cabalResolvedComponents + let graph = map GM.gmcHomeModuleGraph $ Map.elems mcs + return $ graph + Nothing -> return [] -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/MonadFunctions.hs b/src/Language/Haskell/Refact/Utils/MonadFunctions.hs --- a/src/Language/Haskell/Refact/Utils/MonadFunctions.hs +++ b/src/Language/Haskell/Refact/Utils/MonadFunctions.hs @@ -1,11 +1,13 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- For HasTransform + -- | -- This module provides the primary interface to the combined @@ -33,6 +35,7 @@ -- * Annotations -- , addRefactAnns , setRefactAnns + , mergeRefactAnns -- * , putParsedModule @@ -67,7 +70,8 @@ , logAnns , logParsedSource , logExactprint - + , exactPrintParsed + , exactPrintExpr -- * For use by the tests only , initRefactModule , initTokenCacheLayout @@ -87,6 +91,7 @@ #endif import qualified Data.Generics as SYB +-- import qualified GHC.SYB.Utils as SYB import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Annotate @@ -110,7 +115,7 @@ -- --------------------------------------------------------------------- -getTypecheckedModule :: RefactGhc GHC.TypecheckedModule +getTypecheckedModule :: RefactGhc TypecheckedModule getTypecheckedModule = do mtm <- gets rsModule case mtm of @@ -138,7 +143,7 @@ getRefactRenamed = do mtm <- gets rsModule let tm = gfromJust "getRefactRenamed" mtm - return $ gfromJust "getRefactRenamed2" $ GHC.tm_renamed_source $ rsTypecheckedMod tm + return $ tmRenamedSource $ rsTypecheckedMod tm putRefactRenamed :: GHC.RenamedSource -> RefactGhc () putRefactRenamed renamed = do @@ -146,7 +151,7 @@ mrm <- gets rsModule let rm = gfromJust "putRefactRenamed" mrm let tm = rsTypecheckedMod rm - let tm' = tm { GHC.tm_renamed_source = Just renamed } + let tm' = tm { tmRenamedSource = renamed } let rm' = rm { rsTypecheckedMod = tm' } put $ st {rsModule = Just rm'} @@ -156,7 +161,7 @@ let tm = gfromJust "getRefactParsed" mtm let t = rsTypecheckedMod tm - let pm = GHC.tm_parsed_module t + let pm = tmParsedModule t return $ GHC.pm_parsed_source pm putRefactParsed :: GHC.ParsedSource -> Anns -> RefactGhc () @@ -169,8 +174,8 @@ -- let tk' = modifyAnns (rsTokenCache rm) (const newAnns) let tk' = modifyAnns (rsTokenCache rm) (mergeAnns newAnns) - let pm = (GHC.tm_parsed_module tm) { GHC.pm_parsed_source = parsed } - let tm' = tm { GHC.tm_parsed_module = pm } + let pm = (tmParsedModule tm) { GHC.pm_parsed_source = parsed } + let tm' = tm { tmParsedModule = pm } let rm' = rm { rsTypecheckedMod = tm', rsTokenCache = tk', rsStreamModified = RefacModified } put $ st {rsModule = Just rm'} @@ -183,6 +188,14 @@ (Map.! mainTid) . tkCache . rsTokenCache . gfromJust "getRefactAnns" <$> gets rsModule +-- |Merges new annotations with the currecnt annotations from the +-- RefactGhc state. +mergeRefactAnns :: Anns -> RefactGhc () +mergeRefactAnns anns = do + currAnns <- getRefactAnns + let newAnns = Map.union anns currAnns + setRefactAnns newAnns + -- |Internal low level interface to access the current annotations from the -- RefactGhc state. setRefactAnns :: Anns -> RefactGhc () @@ -212,7 +225,7 @@ -- ---------------------------------------------------------------------- -putParsedModule :: [Comment] -> GHC.TypecheckedModule -> RefactGhc () +putParsedModule :: [Comment] -> TypecheckedModule -> RefactGhc () putParsedModule cppComments tm = do st <- get put $ st { rsModule = initRefactModule cppComments tm } @@ -311,7 +324,7 @@ case mtm of Nothing -> return Nothing Just tm -> return $ Just (fileNameFromModSummary $ GHC.pm_mod_summary - $ GHC.tm_parsed_module $ rsTypecheckedMod tm) + $ tmParsedModule $ rsTypecheckedMod tm) -- --------------------------------------------------------------------- @@ -331,7 +344,7 @@ Nothing -> error $ "Hare.MonadFunctions.getRefactModule:no module loaded" Just tm -> do let t = rsTypecheckedMod tm - let pm = GHC.tm_parsed_module t + let pm = tmParsedModule t return (GHC.ms_mod $ GHC.pm_mod_summary pm) -- --------------------------------------------------------------------- @@ -426,14 +439,35 @@ -- --------------------------------------------------------------------- -initRefactModule :: [Comment] -> GHC.TypecheckedModule -> Maybe RefactModule +--Useful helper function that logs the current refact parsed + +exactPrintParsed :: RefactGhc () +exactPrintParsed = do + parsed <- getRefactParsed + anns <- fetchAnnsFinal + let str = exactPrint parsed anns + logm str + +-- --------------------------------------------------------------------- +--A helper function that logs chunks of ast + +exactPrintExpr :: Annotate ast => GHC.Located ast -> RefactGhc () +exactPrintExpr ast = do + anns <- fetchAnnsFinal + let str = exactPrint ast anns + logm str + +-- --------------------------------------------------------------------- + + +initRefactModule :: [Comment] -> TypecheckedModule -> Maybe RefactModule initRefactModule cppComments tm = Just (RefMod { rsTypecheckedMod = tm , rsNameMap = initRdrNameMap tm , rsTokenCache = initTokenCacheLayout (relativiseApiAnnsWithComments cppComments - (GHC.pm_parsed_source $ GHC.tm_parsed_module tm) - (GHC.pm_annotations $ GHC.tm_parsed_module tm)) + (GHC.pm_parsed_source $ tmParsedModule tm) + (GHC.pm_annotations $ tmParsedModule tm)) , rsStreamModified = RefacUnmodifed }) @@ -450,13 +484,13 @@ -- with the wrinkle that we need to Location of the RdrName to make sure we have -- the right Name, but not all RdrNames have a Location. -- This function is called before the RefactGhc monad is active. -initRdrNameMap :: GHC.TypecheckedModule -> NameMap +initRdrNameMap :: TypecheckedModule -> NameMap initRdrNameMap tm = r where - parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module tm - renamed = gfromJust "initRdrNameMap" $ GHC.tm_renamed_source tm + parsed = GHC.pm_parsed_source $ tmParsedModule tm + renamed = tmRenamedSource tm #if __GLASGOW_HASKELL__ > 710 - typechecked = GHC.tm_typechecked_source tm + typechecked = tmTypecheckedSource tm #endif checkRdr :: GHC.Located GHC.RdrName -> Maybe [(GHC.SrcSpan,GHC.RdrName)] diff --git a/src/Language/Haskell/Refact/Utils/Query.hs b/src/Language/Haskell/Refact/Utils/Query.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Refact/Utils/Query.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Language.Haskell.Refact.Utils.Query where +--This module contains functions that retrieve sections of the ast. It is fairly high level. + +import qualified GHC as GHC +import Language.Haskell.Refact.Utils.Monad +import Language.Haskell.Refact.Utils.Synonyms +import Language.Haskell.Refact.Utils.Types +import Language.Haskell.Refact.Utils.TypeUtils +import Data.Generics as SYB +import GHC.SYB.Utils as SYB +import Control.Applicative +import FastString +import RdrName + +--Takes a single match and returns a tuple containing the grhs and the pattern +--Assumptions: + -- Only a single pattern will be returned. Which pattern is returned depends on the behaviour of SYB.something. +getVarAndRHS :: GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.LPat GHC.RdrName, ParsedGRHSs) +getVarAndRHS match = do + let (Just pat) = SYB.something (Nothing `SYB.mkQ` varPat) (GHC.m_pats match) + return (pat , GHC.m_grhss match) + where varPat lPat@(GHC.L _ (GHC.VarPat _ )) = Just lPat + varPat _ = Nothing + +--Looks up the function binding at the given position. Returns nothing if the position does not contain a binding. +getHsBind :: (Data a) => SimpPos -> String -> a -> Maybe (GHC.HsBind GHC.RdrName) +getHsBind pos funNm a = + let rdrNm = locToRdrName pos a in + case rdrNm of + Nothing -> Nothing + (Just (GHC.L _ rNm)) -> SYB.everythingStaged SYB.Parser (<|>) Nothing (Nothing `SYB.mkQ` isBind) a + where +#if __GLASGOW_HASKELL__ <= 710 + isBind (bnd@(GHC.FunBind (GHC.L _ name) _ _ _ _ _) :: GHC.HsBind GHC.RdrName) +#else + isBind (bnd@(GHC.FunBind (GHC.L _ name) _ _ _ _) :: GHC.HsBind GHC.RdrName) +#endif + | name == rNm = (Just bnd) + isBind _ = Nothing + +--It's common to want to know if an expression is just a certain var +--This function takes a String of the var and returns true of the given expression represents that var +isHsVar :: String -> ParsedExpr -> Bool +#if __GLASGOW_HASKELL__ <= 710 +isHsVar str (GHC.HsVar rNm) = +#else +isHsVar str (GHC.HsVar (GHC.L _ rNm)) = +#endif + let nm = mkVarUnqual (fsLit str) in + rNm == nm +isHsVar _ _ = False diff --git a/src/Language/Haskell/Refact/Utils/Synonyms.hs b/src/Language/Haskell/Refact/Utils/Synonyms.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Refact/Utils/Synonyms.hs @@ -0,0 +1,15 @@ +module Language.Haskell.Refact.Utils.Synonyms where +import GHC + +{- +This file has synonyms for commonly used AST parser types. +-} + +type UnlocParsedHsBind = HsBindLR RdrName RdrName +type ParsedGRHSs = GRHSs RdrName (LHsExpr RdrName) +type ParsedMatchGroup = MatchGroup RdrName (LHsExpr RdrName) +type ParsedLMatch = LMatch RdrName (LHsExpr RdrName) +type ParsedExpr = HsExpr RdrName +type ParsedLExpr = LHsExpr RdrName +type ParsedLStmt = LStmt RdrName (LHsExpr RdrName) +type ParsedBind = HsBind RdrName diff --git a/src/Language/Haskell/Refact/Utils/Transform.hs b/src/Language/Haskell/Refact/Utils/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Refact/Utils/Transform.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE CPP #-} +module Language.Haskell.Refact.Utils.Transform + ( + addSimpleImportDecl + , wrapInLambda + , wrapInPars + , wrapInParsWithDPs + , addNewLines + , locate + , removePars + ) where + +import qualified GHC as GHC +import qualified BasicTypes as GHC +import qualified Data.Map as Map +import Data.Data + +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Types + +import Language.Haskell.Refact.Utils.Monad +import Language.Haskell.Refact.Utils.MonadFunctions +import Language.Haskell.Refact.Utils.TypeUtils +import Language.Haskell.Refact.Utils.Synonyms +import Language.Haskell.Refact.Utils.ExactPrint + +-- The goal of this module is to provide basic transformations of the ast and +-- annotations that are useful in multiple refactorings + + +--Takes in a string corresponding to the module name to be imported +--Adds the import declaration at the end of that module's imports +addSimpleImportDecl :: String -> RefactGhc () +addSimpleImportDecl modName = do + let modNm' = GHC.mkModuleName modName + parsed <- getRefactParsed + newP <- addImportDecl parsed modNm' Nothing False False False Nothing False [] + currAnns <- fetchAnnsFinal + putRefactParsed newP currAnns + +--Takes in a lhs pattern and a rhs. Wraps those in a lambda and adds the annotations associated with the lambda. Returns the new located lambda expression + +wrapInLambda :: String -> GHC.LPat GHC.RdrName -> ParsedGRHSs -> RefactGhc (GHC.LHsExpr GHC.RdrName) +wrapInLambda funNm varPat rhs = do + match@(GHC.L l match') <- mkMatch varPat rhs + --logm $ "Match: " ++ (SYB.showData SYB.Parser 3 match) +#if __GLASGOW_HASKELL__ <= 710 + let mg = GHC.MG [match] [] GHC.PlaceHolder GHC.Generated +#else + lMatchLst <- locate [match] + let mg = GHC.MG lMatchLst [] GHC.PlaceHolder GHC.Generated +#endif + currAnns <- fetchAnnsFinal + --logm $ "Anns :" ++ (show $ getAllAnns currAnns match) + let l_lam = (GHC.L l (GHC.HsLam mg)) + key = mkAnnKey l_lam + dp = [(G GHC.AnnLam, DP (0,0))] + newAnn = annNone {annsDP = dp} + setRefactAnns $ Map.insert key newAnn currAnns + par_lam <- wrapInPars l_lam + return par_lam + + --This function makes a match suitable for use inside of a lambda expression. Should change name or define it elsewhere to show that this is not a general-use function. +mkMatch :: GHC.LPat GHC.RdrName -> GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) +mkMatch varPat rhs = do +#if __GLASGOW_HASKELL__ <= 710 + lMatch@(GHC.L l m) <- locate (GHC.Match Nothing [varPat] Nothing rhs) +#else + lMatch@(GHC.L l m) <- locate (GHC.Match GHC.NonFunBindMatch [varPat] Nothing rhs) +#endif + let dp = [(G GHC.AnnRarrow, DP (0,1))] + newAnn = annNone {annsDP = dp, annEntryDelta = DP (0,-1)} + zeroDP varPat + addAnn lMatch newAnn + return lMatch + +wrapInParsWithDPs :: DeltaPos -> DeltaPos -> GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName) +wrapInParsWithDPs openDP closeDP expr = do + newAst <- locate (GHC.HsPar expr) + let dp = [(G GHC.AnnOpenP, openDP), (G GHC.AnnCloseP, closeDP)] + newAnn = annNone {annsDP = dp} + addAnn newAst newAnn + return newAst + + +--Wraps a given expression in parenthesis and add the appropriate annotations, returns the modified ast chunk. +wrapInPars :: GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName) +wrapInPars = wrapInParsWithDPs (DP (0,1)) (DP (0,0)) + +--Does the opposite of wrapInPars +removePars :: ParsedLExpr -> RefactGhc ParsedLExpr +removePars (GHC.L _ (GHC.HsPar expr)) = do + setDP (DP (0,1)) expr + return expr +removePars expr = return expr + + +--Takes a piece of AST and adds an n row offset +addNewLines :: (Data a) => Int -> GHC.Located a -> RefactGhc () +addNewLines n ast = do + currAnns <- fetchAnnsFinal + let key = mkAnnKey ast + mv = Map.lookup key currAnns + case mv of + Nothing -> return () + Just v -> do + let (DP (row,col)) = annEntryDelta v + newDP = (DP (row+n,col)) + newAnn = v {annEntryDelta = newDP} + newAnns = Map.insert key newAnn currAnns + setRefactAnns newAnns diff --git a/src/Language/Haskell/Refact/Utils/TypeSyn.hs b/src/Language/Haskell/Refact/Utils/TypeSyn.hs --- a/src/Language/Haskell/Refact/Utils/TypeSyn.hs +++ b/src/Language/Haskell/Refact/Utils/TypeSyn.hs @@ -51,10 +51,10 @@ ppr x = GHC.text $ show x + instance GHC.Outputable (GHC.MatchGroup GHC.Name (GHC.LHsExpr GHC.Name)) where ppr (GHC.MG ms _ _ _) = GHC.text "MatchGroup" GHC.<+> GHC.ppr ms - instance GHC.Outputable (GHC.Match GHC.Name (GHC.LHsExpr GHC.Name)) where ppr (GHC.Match _fn pats mtyp grhs) = GHC.text "Match" GHC.<+> GHC.ppr pats GHC.<+> GHC.ppr mtyp @@ -76,11 +76,14 @@ ppr (GHC.Missing _typ) = GHC.text "Missing" +#if !(defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,0,1,1))) instance GHC.Outputable (GHC.ConDeclField GHC.Name) where ppr (GHC.ConDeclField name typ doc) = GHC.text "ConDeclField" GHC.<+> GHC.ppr name GHC.<+> GHC.ppr typ GHC.<+> GHC.ppr doc +#endif + #if __GLASGOW_HASKELL__ <= 710 instance GHC.Outputable (GHC.TyFamEqn GHC.Name (GHC.LHsTyVarBndrs GHC.Name)) where ppr (GHC.TyFamEqn name pats rhs) = GHC.text "TyFamEqn" @@ -90,4 +93,3 @@ #endif -- --------------------------------------------------------------------- - 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 @@ -46,7 +46,8 @@ , hsQualifier -- ** Property checking - ,isVarId,isConId,isOperator,isTopLevelPN,isLocalPN,isNonLibraryName + ,isVarId,isConId,isOperator + ,isTopLevelPN,isLocalPN,isNonLibraryName ,isQualifiedPN, isFunOrPatName, isTypeSig, isTypeSigDecl ,isFunBindP,isFunBindR,isPatBindP,isPatBindR,isSimplePatBind,isSimplePatDecl ,isComplexPatBind,isComplexPatDecl,isFunOrPatBindP,isFunOrPatBindR @@ -132,10 +133,12 @@ -- Modules from GHC +import qualified Avail as GHC import qualified FastString as GHC import qualified GHC as GHC import qualified Module as GHC import qualified Name as GHC +import qualified NameSet as GHC import qualified Outputable as GHC import qualified RdrName as GHC import qualified TyCon as GHC @@ -206,19 +209,16 @@ -> RefactGhc Bool -- ^ The result. isInScopeAndUnqualifiedGhc n maybeExising = do names <- ghandle handler (GHC.parseName n) - logm $ "isInScopeAndUnqualifiedGhc:(n,(maybeExising,names))=" ++ (show n) ++ ":" ++ (showGhc (maybeExising,names)) - ctx <- GHC.getContext - logm $ "isInScopeAndUnqualifiedGhc:ctx=" ++ (showGhc ctx) let nameList = case maybeExising of Nothing -> names Just n' -> filter (\x -> (showGhcQual x) /= (showGhcQual n')) names - logm $ "isInScopeAndUnqualifiedGhc:(n,nameList)=" ++ (show n) ++ ":" ++ (showGhc nameList) + -- logm $ "isInScopeAndUnqualifiedGhc:(n,nameList)=" ++ (show n) ++ ":" ++ (showGhc nameList) return $ nameList /= [] where handler:: SomeException -> RefactGhc [GHC.Name] - handler e = do - logm $ "isInScopeAndUnqualifiedGhc.handler e=" ++ (show e) + handler _e = do + -- logm $ "isInScopeAndUnqualifiedGhc.handler e=" ++ (show _e) return [] -- --------------------------------------------------------------------- @@ -262,10 +262,10 @@ let eqModules (GHC.Module pk1 mn1) (GHC.Module pk2 mn2) = mn1 == mn2 && pk1 == pk2 gnames <- GHC.getNamesInScope - logm $ "equivalentNameInNewMod:gnames=" ++ showGhcQual (map (\n -> (GHC.nameModule n,n)) gnames) + -- logm $ "equivalentNameInNewMod:gnames=" ++ showGhcQual (map (\n -> (GHC.nameModule n,n)) gnames) let clientModule = GHC.nameModule old logm $ "equivalentNameInNewMod:(old,clientModule)=" ++ showGhcQual (old,clientModule) - let clientInscopes = filter (\n -> clientModule == GHC.nameModule n) gnames + -- let clientInscopes = filter (\n -> clientModule == GHC.nameModule n) gnames let clientInscopes = filter (\n -> eqModules clientModule (GHC.nameModule n)) gnames logm $ "equivalentNameInNewMod:clientInscopes=" ++ showGhcQual clientInscopes let newNames = filter (\n -> showGhcQual n == showGhcQual old) clientInscopes @@ -378,9 +378,15 @@ isExported :: GHC.Name -> RefactGhc Bool isExported n = do typechecked <- getTypecheckedModule - let modInfo = GHC.tm_checked_module_info typechecked - return $ GHC.modInfoIsExportedName modInfo n + -- let modInfo = GHC.tm_checked_module_info typechecked + -- return $ GHC.modInfoIsExportedName modInfo n + return $ GHC.elemNameSet n (GHC.availsToNameSet (tmMinfExports typechecked)) + +-- modInfoIsExportedName :: ModuleInfo -> Name -> Bool +-- modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf)) + + -- --------------------------------------------------------------------- -- | Return True if an identifier is explicitly exported by the module. @@ -398,7 +404,7 @@ -> GHC.Name -- ^ The original name -> GHC.Name -- ^ The new name -> GHC.ModuleName -- ^ The identity of the module - -> GHC.ParsedSource -- ^ The AST of the module + -> GHC.ParsedSource -- ^ The AST of the module -> Bool -- ^ The result -- Note that in the abstract representation of exps, there is no qualified entities. @@ -459,7 +465,7 @@ getModule :: RefactGhc GHC.Module getModule = do typechecked <- getTypecheckedModule - return $ GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module typechecked + return $ GHC.ms_mod $ GHC.pm_mod_summary $ tmParsedModule typechecked -- --------------------------------------------------------------------- @@ -488,7 +494,7 @@ -- | Returns True if a string lexically is an identifier. -- *This function should not be exported.* -isId::String->Bool +isId :: String -> Bool isId mid = mid/=[] && isLegalIdTail (tail mid) && not (isReservedId mid) where isLegalIdTail tail' = all isLegal tail' @@ -507,11 +513,15 @@ isTopLevelPN::GHC.Name -> RefactGhc Bool isTopLevelPN n = do typechecked <- getTypecheckedModule - let maybeNames = GHC.modInfoTopLevelScope $ GHC.tm_checked_module_info typechecked + let maybeNames = modInfoTopLevelScope typechecked let names = fromMaybe [] maybeNames return $ n `elem` names +modInfoTopLevelScope :: TypecheckedModule -> Maybe [GHC.Name] +modInfoTopLevelScope tm + = fmap (map GHC.gre_name . GHC.globalRdrEnvElts) (tmMinfRdrEnv tm) + -- |Return True if a PName is a local PName. isLocalPN::GHC.Name -> Bool isLocalPN = GHC.isInternalName @@ -1043,10 +1053,11 @@ mkNewEnt addCommaAnn pn = do newSpan <- liftT uniqueSrcSpanT let lpn = GHC.L newSpan pn - if addCommaAnn - then liftT $ addSimpleAnnT lpn (DP (0,0)) [((G GHC.AnnVal),DP (0,0)),((G GHC.AnnComma),DP (0,0))] - else liftT $ addSimpleAnnT lpn (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] - return (GHC.L newSpan (GHC.IEVar lpn)) + let lie = GHC.L newSpan (GHC.IEVar lpn) + liftT $ addSimpleAnnT lpn (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] + when addCommaAnn $ + liftT $ addSimpleAnnT lie (DP (0,0)) [((G GHC.AnnComma),DP (0,0))] + return lie -- | Represents the operation type we want to select on addItemsToImport' data ImportType = Hide -- ^ Used for addHiding @@ -1061,7 +1072,7 @@ -> Either [GHC.RdrName] [GHC.LIE GHC.RdrName] -- ^ The items to be added -> GHC.ParsedSource -- ^ The current module -> RefactGhc GHC.ParsedSource -- ^ The result -addItemsToImport mn mc ns r = addItemsToImport' mn r ns Import +addItemsToImport mn _mc ns r = addItemsToImport' mn r ns Import -- | Add identifiers (given by the third argument) to the explicit entity list -- in the declaration importing the specified module name. If the ImportType @@ -1573,7 +1584,7 @@ addActualParamsToRhs :: (SYB.Data t) => GHC.Name -> [GHC.RdrName] -> t -> RefactGhc t addActualParamsToRhs pn paramPNames rhs = do - logm $ "addActualParamsToRhs:entered:(pn,paramPNames)=" ++ showGhc (pn,paramPNames) + -- logm $ "addActualParamsToRhs:entered:(pn,paramPNames)=" ++ showGhc (pn,paramPNames) nameMap <- getRefactNameMap let worker :: (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.LHsExpr GHC.RdrName) @@ -1584,7 +1595,7 @@ #endif | eqRdrNamePure nameMap (GHC.L l2 pname) pn = do - logDataWithAnns "addActualParamsToRhs:oldExp=" oldExp + -- logDataWithAnns "addActualParamsToRhs:oldExp=" oldExp newExp' <- foldlM addParamToExp oldExp paramPNames edp <- liftT $ getEntryDPT oldExp @@ -1600,14 +1611,15 @@ addParamToExp expr param = do ss1 <- liftT $ uniqueSrcSpanT ss2 <- liftT $ uniqueSrcSpanT - logm $ "addActualParamsToRhs.addParamsToExp:(ss1,ss2):" ++ showGhc (ss1,ss2) + -- logm $ "addActualParamsToRhs.addParamsToExp:(ss1,ss2):" ++ showGhc (ss1,ss2) registerRdrName (GHC.L ss2 param) #if __GLASGOW_HASKELL__ <= 710 let var = GHC.L ss2 (GHC.HsVar param) + liftT $ addSimpleAnnT var (DP (0,0)) [(G GHC.AnnVal,DP (0,1))] #else let var = GHC.L ss2 (GHC.HsVar (GHC.L ss2 param)) + liftT $ addSimpleAnnT (GHC.L ss2 param) (DP (0,0)) [(G GHC.AnnVal,DP (0,1))] #endif - liftT $ addSimpleAnnT var (DP (0,0)) [(G GHC.AnnVal,DP (0,1))] let expr' = GHC.L ss1 (GHC.HsApp expr var) liftT $ addSimpleAnnT expr' (DP (0,0)) [] return expr' @@ -1817,10 +1829,10 @@ rmDecl pn incSig t = do setStateStorage StorageNone - t' <- everywhereMStaged' SYB.Parser (SYB.mkM inModule - `SYB.extM` inLet - `SYB.extM` inMatch - ) t -- top down + t' <- everywhereM' (SYB.mkM inModule + `SYB.extM` inLet + `SYB.extM` inMatch + ) t -- top down -- applyTP (once_tdTP (failTP `adhocTP` inBinds)) t storage <- getStateStorage let decl' = case storage of @@ -1939,9 +1951,9 @@ doRmDecl :: [GHC.LHsDecl GHC.RdrName] -> [GHC.LHsDecl GHC.RdrName] -> RefactGhc [GHC.LHsDecl GHC.RdrName] doRmDecl decls1 decls2 = do + let decls2' = gtail "doRmDecl 1" decls2 declToRemove = head decls2 - -- logDataWithAnns "doRmDecl:(decls1,decls2)" (decls1,decls2) unless (null decls1) $ do liftT $ balanceComments (last decls1) declToRemove unless (null decls2') $ do liftT $ balanceComments declToRemove (head decls2') @@ -2129,11 +2141,8 @@ renamePN oldPN newName useQual t = do -- logm $ "renamePN: (oldPN,newName)=" ++ (showGhc (oldPN,newName)) -- logm $ "renamePN: t=" ++ (SYB.showData SYB.Parser 0 t) - -- nm <- getRefactNameMap newNameQual <- rdrNameFromName True newName newNameUnqual <- rdrNameFromName False newName - -- newNameRdr <- rdrNameFromName useQual newName - -- logm $ "renamePN: (newNameQual,newNameUnqual,newNameRdr)=" ++ showGhc (newNameQual,newNameUnqual,newNameRdr) let cond :: NameMap -> GHC.Located GHC.RdrName -> Bool @@ -2164,22 +2173,6 @@ -- --------------------------------- - renameLRdr :: HowToQual -> GHC.Located GHC.RdrName -> RefactGhc (GHC.Located GHC.RdrName) - renameLRdr useQual' old@(GHC.L _ n) = do - nm <- getRefactNameMap - if cond nm old - then do - logDataWithAnns "renamePN:rename old :" old - -- let nn = newNameCalcBool useQual' n - let nn = newNameCalc useQual' n - new <- makeNewName old nn - logDataWithAnns "renamePN:rename new :" new - logDataWithAnns "renamePN:rename old2 :" old - return new - else return old - - -- --------------------------------- - renameVar :: HowToQual -> GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName) #if __GLASGOW_HASKELL__ <= 710 renameVar useQual' x@(GHC.L l (GHC.HsVar n)) = do @@ -2205,6 +2198,21 @@ -- --------------------------------- + renameLRdr :: HowToQual -> GHC.Located GHC.RdrName -> RefactGhc (GHC.Located GHC.RdrName) + renameLRdr useQual' old@(GHC.L _ n) = do + nm <- getRefactNameMap + if cond nm old + then do + -- logDataWithAnns "renamePN:rename old :" old + let nn = newNameCalc useQual' n + new <- makeNewName old nn + -- logDataWithAnns "renamePN:rename new :" new + -- logDataWithAnns "renamePN:rename old2 :" old + return new + else return old + + -- --------------------------------- + renameTyVar :: HowToQual -> (GHC.Located (GHC.HsType GHC.RdrName)) -> RefactGhc (GHC.Located (GHC.HsType GHC.RdrName)) #if __GLASGOW_HASKELL__ <= 710 renameTyVar useQual' x@(GHC.L l (GHC.HsTyVar n)) = do @@ -2214,7 +2222,7 @@ nm <- getRefactNameMap if cond nm (GHC.L l n) then do - logm $ "renamePN:renameTyVar at :" ++ (showGhc l) + -- logm $ "renamePN:renameTyVar at :" ++ (showGhc l) let nn = newNameCalc useQual' n #if __GLASGOW_HASKELL__ <= 710 ss' <- liftT $ uniqueSrcSpanT @@ -2240,8 +2248,7 @@ nm <- getRefactNameMap if cond nm (GHC.L l n) then do - logm $ "renamePN:renameHsTyVarBndr at :" ++ (showGhc l) - -- let nn = newNameCalcBool useQual' n + -- logm $ "renamePN:renameHsTyVarBndr at :" ++ (showGhc l) let nn = newNameCalc useQual' n #if __GLASGOW_HASKELL__ <= 710 addToNameMap l newName @@ -2334,7 +2341,7 @@ nm <- getRefactNameMap if cond nm (GHC.L l n) then do - logm $ "renamePNworker:renameLPat at :" ++ (showGhc l) + -- logm $ "renamePNworker:renameLPat at :" ++ (showGhc l) let nn = newNameCalc useQual' n #if __GLASGOW_HASKELL__ <= 710 ss' <- liftT $ uniqueSrcSpanT @@ -2354,7 +2361,7 @@ renameMatch :: HowToQual -> GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) renameMatch _useQual (GHC.Match mln pats ty grhss) = do - logm $ "renamePN.renameMatch entered:" + -- logm $ "renamePN.renameMatch entered:" pats' <- renameTransform _useQual pats ty' <- renameTransform _useQual ty grhss' <- renameTransform _useQual grhss @@ -2398,10 +2405,10 @@ renameTypeSig _useQual (GHC.TypeSig ns typ) #endif = do - logm $ "renamePN:renameTypeSig" + -- logm $ "renamePN:renameTypeSig" ns' <- mapM (renameLRdr NoQualify) ns typ' <- renameTransform _useQual typ - logm $ "renamePN:renameTypeSig done" + -- logm $ "renamePN:renameTypeSig done" #if __GLASGOW_HASKELL__ <= 710 return (GHC.TypeSig ns' typ' p) #else @@ -2430,6 +2437,9 @@ match = const True :: GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Bool importDecl = const True :: GHC.ImportDecl GHC.RdrName -> Bool + -- The function that does the actual renaming. It is split out here so it + -- can be called recursively. + renameTransform :: (SYB.Data t) => HowToQual -> t -> RefactGhc t renameTransform useQual' t' = (everywhereMSkip ( -- top-down, skipping Located Names for Sig/Match SYB.mkM (renameVar useQual') @@ -2442,8 +2452,7 @@ `SYB.extM` (renameImportDecl useQual') `SYB.extM` (renameMatch useQual') ) t') - t' <- renameTransform useQual t - return t' + renameTransform useQual t -- --------------------------------------------------------------------- @@ -2503,7 +2512,7 @@ findIdForName :: GHC.Name -> RefactGhc (Maybe GHC.Id) findIdForName n = do tm <- getTypecheckedModule - let t = GHC.tm_typechecked_source tm + let t = tmTypecheckedSource tm let r = SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker) t worker (i::GHC.Id) | (GHC.nameUnique n) == (GHC.varUnique i) = Just i @@ -2586,4 +2595,3 @@ #endif -- EOF - diff --git a/src/Language/Haskell/Refact/Utils/Types.hs b/src/Language/Haskell/Refact/Utils/Types.hs --- a/src/Language/Haskell/Refact/Utils/Types.hs +++ b/src/Language/Haskell/Refact/Utils/Types.hs @@ -4,6 +4,7 @@ ( ApplyRefacResult , RefacResult(..) + , TypecheckedModule(..) -- * , TreeId(..) , mainTid @@ -14,9 +15,9 @@ ) where +import qualified Avail as GHC import qualified GHC as GHC --- import qualified Name as GHC --- import qualified Outputable as GHC +import qualified RdrName as GHC import Language.Haskell.GHC.ExactPrint -- import Language.Haskell.GHC.ExactPrint.Utils @@ -31,6 +32,22 @@ data RefacResult = RefacModified | RefacUnmodifed deriving (Show,Ord,Eq) + +-- --------------------------------------------------------------------- + +data TypecheckedModule = TypecheckedModule + { tmParsedModule :: !GHC.ParsedModule + , tmRenamedSource :: !GHC.RenamedSource + , tmTypecheckedSource :: !GHC.TypecheckedSource + -- , tmMinfExports :: ![GHC.AvailInfo] + -- , tmMinfRdrEnv :: !(Maybe GHC.GlobalRdrEnv) -- Nothing for a compiled/package mod + , tmMinfExports :: [GHC.AvailInfo] + , tmMinfRdrEnv :: (Maybe GHC.GlobalRdrEnv) -- Nothing for a compiled/package mod + } + +-- TODO: improve this, or remove it's need +instance Show TypecheckedModule where + show _ = "TypeCheckedModule(..)" -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/Utils.hs b/src/Language/Haskell/Refact/Utils/Utils.hs --- a/src/Language/Haskell/Refact/Utils/Utils.hs +++ b/src/Language/Haskell/Refact/Utils/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -17,6 +18,7 @@ -- * The bits that do the work , runRefacSession , applyRefac + , applyRefac' , refactDone -- , Update(..) @@ -24,6 +26,8 @@ , getModuleName , clientModsAndFiles , serverModsAndFiles + -- , lookupAnns + , runMultRefacSession , modifiedFiles , writeRefactoredFiles @@ -36,11 +40,12 @@ import Control.Monad.Identity import Control.Monad.State import Data.List +import Data.Maybe +import Data.IORef -- import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Preprocess import Language.Haskell.GHC.ExactPrint.Print -import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils import qualified Language.Haskell.GhcMod as GM @@ -57,7 +62,11 @@ import qualified Digraph as GHC import qualified DynFlags as GHC import qualified GHC as GHC --- import qualified Outputable as GHC +-- import qualified SrcLoc as GHC +import qualified Hooks as GHC +import qualified HscMain as GHC +import qualified HscTypes as GHC +import qualified TcRnMonad as GHC -- import qualified GHC.SYB.Utils as SYB -- import qualified Data.Generics as SYB @@ -82,30 +91,127 @@ getTargetGhc (GM.ModulePath _mn fp) = parseSourceFileGhc fp -- --------------------------------------------------------------------- +{- +-- | Parse a single source file into a GHC session +parseSourceFileGhc' :: FilePath -> RefactGhc () +parseSourceFileGhc' targetFile = do + logm $ "parseSourceFileGhc:targetFile=" ++ show targetFile + setTargetSession targetFile + graph <- GHC.getModuleGraph + cgraph <- canonicalizeGraph graph + cfileName <- liftIO $ canonicalizePath targetFile + let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph + case mm of + [(_,modSum)] -> loadFromModSummary Nothing modSum + _ -> error $ "HaRe:unexpected error parsing " ++ targetFile +-} +-- --------------------------------------------------------------------- -- | Parse a single source file into a GHC session parseSourceFileGhc :: FilePath -> RefactGhc () parseSourceFileGhc targetFile = do logm $ "parseSourceFileGhc:targetFile=" ++ show targetFile - setTargetSession targetFile - logm $ "parseSourceFileGhc:after setTargetSession" + cfileName <- liftIO $ canonicalizePath targetFile + logm $ "parseSourceFileGhc:cfileName=" ++ show cfileName + ref <- liftIO $ newIORef (cfileName,Nothing) + let + setTarget fileName = RefactGhc $ GM.runGmlT' [Left fileName] (installHooks ref) (return ()) + -- setTarget targetFile + setTarget cfileName + logm $ "parseSourceFileGhc:after setTarget" + (_,mtm) <- liftIO $ readIORef ref + logm $ "parseSourceFileGhc:isJust mtm:" ++ show (isJust mtm) graph <- GHC.getModuleGraph cgraph <- canonicalizeGraph graph - cfileName <- liftIO $ canonicalizePath targetFile let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph case mm of - [(_,modSum)] -> loadFromModSummary modSum + [(_,modSum)] -> loadFromModSummary mtm modSum + -- [(_,modSum)] -> loadFromModSummary Nothing modSum _ -> error $ "HaRe:unexpected error parsing " ++ targetFile -- --------------------------------------------------------------------- +installHooks :: (Monad m) => IORef (FilePath,Maybe TypecheckedModule) -> GHC.DynFlags -> m GHC.DynFlags +installHooks ref dflags = return $ dflags { + GHC.hooks = (GHC.hooks dflags) { + +#if __GLASGOW_HASKELL__ <= 710 + GHC.hscFrontendHook = Just $ hscFrontend ref +#else + GHC.hscFrontendHook = Just $ runHscFrontend ref +#endif + } + } + +#if __GLASGOW_HASKELL__ > 710 +runHscFrontend :: IORef (FilePath,Maybe TypecheckedModule) -> GHC.ModSummary -> GHC.Hsc GHC.FrontendResult +runHscFrontend ref mod_summary + = GHC.FrontendTypecheck `fmap` hscFrontend ref mod_summary +#endif + +-- --------------------------------------------------------------------- +-- | Given a 'ModSummary', parses and typechecks it, returning the +-- 'TcGblEnv' resulting from type-checking. +-- Based on GHC.hscFileFrontend +-- +-- This gets called on every module compiled when loading the wanted target. +-- When it is the wanted target, keep the ParsedSource and TypecheckedSource, +-- with API Annotations enabled. +hscFrontend :: IORef (FilePath,Maybe TypecheckedModule) -> GHC.ModSummary -> GHC.Hsc GHC.TcGblEnv +hscFrontend ref mod_summary = do + -- liftIO $ putStrLn $ "hscFrontend:entered:" ++ fileNameFromModSummary mod_summary + (mfn,_) <- canonicalizeModSummary mod_summary + -- liftIO $ putStrLn $ "hscFrontend:mfn:" ++ show mfn + (fn,_) <- liftIO $ readIORef ref + let + keepInfo = case mfn of + Just fileName -> fn == fileName + Nothing -> False + if keepInfo + then do + -- liftIO $ putStrLn $ "hscFrontend:in keepInfo" + let modSumWithRaw = tweakModSummaryDynFlags mod_summary + + hsc_env <- GHC.getHscEnv + let hsc_env_tmp = hsc_env { GHC.hsc_dflags = GHC.ms_hspp_opts modSumWithRaw } + hpm <- liftIO $ GHC.hscParse hsc_env_tmp modSumWithRaw + let p = GHC.ParsedModule mod_summary + (GHC.hpm_module hpm) + (GHC.hpm_src_files hpm) + (GHC.hpm_annotations hpm) + + hsc_env' <- GHC.getHscEnv + (tc_gbl_env,rn_info) <- liftIO $ GHC.hscTypecheckRename hsc_env' mod_summary hpm + + details <- liftIO $ GHC.makeSimpleDetails hsc_env' tc_gbl_env + + let + tc = + TypecheckedModule { + tmParsedModule = p, + tmRenamedSource = gfromJust "hscFrontend" rn_info, + tmTypecheckedSource = GHC.tcg_binds tc_gbl_env, + tmMinfExports = GHC.md_exports details, + tmMinfRdrEnv = Just (GHC.tcg_rdr_env tc_gbl_env) + } + + liftIO $ modifyIORef' ref (const (fn,Just tc)) + return tc_gbl_env + else do + hpm <- GHC.hscParse' mod_summary + hsc_env <- GHC.getHscEnv + tc_gbl_env <- GHC.tcRnModule' hsc_env mod_summary False hpm + return tc_gbl_env + +-- --------------------------------------------------------------------- +{- setTargetSession :: FilePath -> RefactGhc () -- setTargetSession targetFile = RefactGhc $ GM.runGmlT' [Left targetFile] setDynFlags (return ()) setTargetSession targetFile = RefactGhc $ GM.runGmlT' [Left targetFile] return (return ()) -setDynFlags :: GHC.DynFlags -> GHC.Ghc GHC.DynFlags -setDynFlags df = return (GHC.gopt_set df GHC.Opt_KeepRawTokenStream) - +-- setDynFlags :: GHC.DynFlags -> GHC.Ghc GHC.DynFlags +-- setDynFlags df = return (GHC.gopt_set df GHC.Opt_KeepRawTokenStream) +-} -- --------------------------------------------------------------------- -- |For GHC 7.10.2, setting 'GHC.Opt_KeepRawTokenStream' prevents the pragmas at @@ -123,18 +229,31 @@ -- | In the existing GHC session, put the requested TypeCheckedModule -- into the RefactGhc monad -loadFromModSummary :: GHC.ModSummary -> RefactGhc () -loadFromModSummary modSum = do +loadFromModSummary :: Maybe TypecheckedModule -> GHC.ModSummary -> RefactGhc () +loadFromModSummary mtm modSum = do logm $ "loadFromModSummary:modSum=" ++ show modSum - let modSumWithRaw = tweakModSummaryDynFlags modSum - p <- GHC.parseModule modSumWithRaw - t <- GHC.typecheckModule p + t <- case mtm of + Nothing -> do + let modSumWithRaw = tweakModSummaryDynFlags modSum + p <- GHC.parseModule modSumWithRaw + t' <- GHC.typecheckModule p + let + tm = TypecheckedModule + { tmParsedModule = p + , tmRenamedSource = gfromJust "loadFromModSummary" $ GHC.tm_renamed_source t' + , tmTypecheckedSource = GHC.tm_typechecked_source t' + , tmMinfExports = error $ "loadFromModSummary:not visible in ModuleInfo 1" + , tmMinfRdrEnv = error $ "loadFromModSummary:not visible in ModuleInfo 2" + } + return tm + Just tm -> return tm -- dflags <- GHC.getDynFlags -- cppComments <- if (GHC.xopt GHC.Opt_Cpp dflags) cppComments <- if True then do -- ++AZ++:TODO: enable the CPP option check some time + -- TODO: Set the approriate DynFlag to retain the source, so this can be done more cheaply logm $ "loadFromModSummary:CPP flag set" case GHC.ml_hs_file $ GHC.ms_location modSum of Just fileName -> getCppTokensAsComments defaultCppOptions fileName @@ -158,8 +277,8 @@ settings <- get put $ settings { rsCurrentTarget = Just newTargetModule } - mtm <- gets rsModule - case mtm of + mtm' <- gets rsModule + case mtm' of Just tm -> if ((rsStreamModified tm == RefacUnmodifed) && oldTargetModule == Just newTargetModule) then do @@ -209,6 +328,63 @@ -- --------------------------------------------------------------------- + +-- | Like runRefacSession but instead takes an ordered list of RefactGhc +-- computations and runs all of them threading the state through all of the +-- computations + +runMultRefacSession :: RefactSettings -> GM.Options -> [RefactGhc [ApplyRefacResult]] -> IO [FilePath] +runMultRefacSession settings opt comps = do + let + initialState = RefSt + { rsSettings = settings + , rsUniqState = 1 + , rsSrcSpanCol = 1 + , rsFlags = RefFlags False + , rsStorage = StorageNone + , rsCurrentTarget = Nothing + , rsModule = Nothing + } + results <- threadState opt initialState comps + let (_, finState) = last results + verbosity = rsetVerboseLevel (rsSettings finState) + refResults = map fst results + merged = mergeRefResults refResults + writeRefactoredFiles verbosity merged + return $ modifiedFiles merged + +mergeRefResults :: [[ApplyRefacResult]] -> [ApplyRefacResult] +mergeRefResults lst = Map.elems $ mergeHelp lst Map.empty + where mergeHelp [] mp = mp + mergeHelp (x:xs) mp = mergeHelp xs (foldl insertRefRes mp x) + insertRefRes mp res@((fp,RefacModified), _) = Map.insert fp res mp + insertRefRes mp _ = mp + +-- | Take an ordered list of refactorings and apply them in order, threading the +-- state through all of them +threadState :: GM.Options -> RefactState -> [RefactGhc [ApplyRefacResult]] + -> IO [([ApplyRefacResult], RefactState)] +threadState _ _ [] = return [] +threadState opt currState (rGhc : rst) = do + res@(_rGhcRes, newState) <- runRefactGhc rGhc currState opt + let (Just modu) = rsModule newState + newMod = modu {rsStreamModified = RefacUnmodifed} + nextState = newState {rsModule = Just newMod } + rest <- threadState opt nextState rst + return (res : rest) + +-- --------------------------------------------------------------------- + +cdAndDo :: FilePath -> IO a -> IO a +cdAndDo path fn = do + old <- getCurrentDirectory + r <- GHC.gbracket (setCurrentDirectory path) (\_ -> setCurrentDirectory old) + $ const fn + return r + +-- --------------------------------------------------------------------- + +{- canonicalizeTargets :: Targets-> IO Targets canonicalizeTargets tgts = do cur <- getCurrentDirectory @@ -216,19 +392,27 @@ canonicalizeTarget (Left path) = Left <$> canonicalizePath (cur path) canonicalizeTarget (Right modname) = return $ Right modname mapM canonicalizeTarget tgts - +-} -- --------------------------------------------------------------------- -- TODO: the module should be stored in the state, and returned if it -- has been modified in a prior refactoring, instead of being parsed -- afresh each time. -- | Apply a refactoring (or part of a refactoring) to a single module -applyRefac - :: RefactGhc a -- ^ The refactoring + +applyRefac :: RefactGhc a -> RefacSource -> RefactGhc (ApplyRefacResult, a) +applyRefac = applyRefac' True -- TODO: applyRefac' is never called except from + -- here. Do we always need to clear the state on + -- completion? + +applyRefac' + :: + Bool -- ^ Boolean that determines if the state should be cleared + -> RefactGhc a -- ^ The refactoring -> RefacSource -- ^ where to get the module and toks -> RefactGhc (ApplyRefacResult,a) -applyRefac refac source = do +applyRefac' clearSt refac source = do -- TODO: currently a temporary, poor man's surrounding state -- management: store state now, set it to fresh, run refac, then @@ -253,8 +437,9 @@ m <- getRefactStreamModified -- Clear the refactoring state - clearParsedModule - + if clearSt + then clearParsedModule + else return () absFileName <- liftIO $ canonicalizePath fileName return (((absFileName,m),(anns, mod')),res) @@ -355,10 +540,11 @@ where modifyFile ((fileName,_),(ann,parsed)) = do - let rigidOptions :: PrintOptions Identity String - rigidOptions = printOptions (\_ b -> return b) return return RigidLayout + let + -- rigidOptions :: PrintOptions Identity String + -- rigidOptions = printOptions (\_ b -> return b) return return RigidLayout - exactPrintRigid ast as = runIdentity (exactPrintWithOptions rigidOptions ast as) + -- exactPrintRigid ast as = runIdentity (exactPrintWithOptions rigidOptions ast as) exactPrintNormal ast as = runIdentity (exactPrintWithOptions stringOptions ast as) -- let source = exactPrint parsed ann @@ -387,6 +573,7 @@ -- clientModsAndFiles :: GHC.ModuleName -> RefactGhc [TargetModule] clientModsAndFiles :: GM.ModulePath -> RefactGhc [TargetModule] +-- TODO: Use ghc-mod cache if there is a cabal file, else normal GHC modulegraph clientModsAndFiles m = do mgs <- cabalModuleGraphs -- logm $ "clientModsAndFiles:mgs=" ++ show mgs @@ -433,9 +620,10 @@ -- | Return the server module and file names. The server modules of -- module, say m, are those modules which are directly or indirectly -- imported by module m. This can only be called in a live GHC session --- TODO: make sure this works with multiple targets. Is that needed? No? +-- TODO: make sure this works with multiple targets. Is that needed? serverModsAndFiles :: GHC.GhcMonad m => GHC.ModuleName -> m [GHC.ModSummary] +-- TODO: Use ghc-mod cache if there is a cabal file, else normal GHC modulegraph serverModsAndFiles m = do ms <- GHC.getModuleGraph modsum <- GHC.getModSummary m @@ -446,6 +634,13 @@ return serverMods +-- --------------------------------------------------------------------- +{- +-- | Finds all anotations that are contained within the given source span +lookupAnns :: Anns -> GHC.SrcSpan -> Anns +lookupAnns anns (GHC.RealSrcSpan span) = Map.filterWithKey isInSpan anns + where isInSpan k@(AnnKey (GHC.RealSrcSpan annSpan) conN) v = GHC.containsSpan span annSpan +-} -- --------------------------------------------------------------------- -- | In GHC 8 an error has an attached callstack. This is not always what we diff --git a/src/Language/Haskell/Refact/Utils/Variables.hs b/src/Language/Haskell/Refact/Utils/Variables.hs --- a/src/Language/Haskell/Refact/Utils/Variables.hs +++ b/src/Language/Haskell/Refact/Utils/Variables.hs @@ -18,19 +18,22 @@ , isClassName , isInstanceName , isDeclaredInRdr + , FreeNames(..),DeclaredNames(..) , hsFreeAndDeclaredRdr , hsFreeAndDeclaredNameStrings , hsFreeAndDeclaredPNs - -- , hsFreeAndDeclaredGhc + , getDeclaredTypesRdr , getDeclaredVarsRdr - , hsVisibleNamesRdr + + , hsVisibleNamesRdr, hsVisibleDsRdr , hsFDsFromInsideRdr, hsFDNamesFromInsideRdr, hsFDNamesFromInsideRdrPure - , hsVisibleDsRdr + , rdrName2Name, rdrName2NamePure , eqRdrNamePure -- , rdrName2Name' + , sameNameSpace -- ** Identifiers, expressions, patterns and declarations , FindEntity(..) @@ -40,7 +43,7 @@ , definedPNsRdr,definedNamesRdr , definingDeclsRdrNames,definingDeclsRdrNames',definingSigsRdrNames , definingTyClDeclsNames - , definesRdr,definesDeclRdr + , definesRdr,definesDeclRdr,definesNameRdr , definesTypeSigRdr,definesSigDRdr , hsTypeVbls @@ -54,7 +57,6 @@ import Data.List import Data.Maybe import Data.Monoid --- import Debug.Trace import Language.Haskell.Refact.Utils.GhcVersionSpecific import Language.Haskell.Refact.Utils.LocUtils @@ -71,7 +73,7 @@ import qualified Bag as GHC import qualified GHC as GHC import qualified Name as GHC -import qualified Outputable as GHC +-- import qualified Outputable as GHC import qualified RdrName as GHC import qualified Data.Generics as SYB @@ -246,40 +248,78 @@ -- --------------------------------------------------------------------- +-- |The same as `hsFreeAndDeclaredPNs` except that the returned +-- variables are in the String format. +hsFreeAndDeclaredNameStrings :: (SYB.Data t) + => t -> RefactGhc ([String],[String]) +hsFreeAndDeclaredNameStrings t = do + (f,d) <- hsFreeAndDeclaredPNs t + return ((nub.map showGhc) f, (nub.map showGhc) d) + +-- --------------------------------------------------------------------- + +-- | Return the free and declared Names in the given syntax fragment. The syntax +-- fragment MUST be parameterised by RdrName, else the empty list will be +-- returned. +hsFreeAndDeclaredPNs :: (SYB.Data t) => t -> RefactGhc ([GHC.Name],[GHC.Name]) +hsFreeAndDeclaredPNs t = do + nm <- getRefactNameMap + -- TODO: Change the return type to (FreeNames,DeclaredNames) + let (FN f,DN d) = hsFreeAndDeclaredRdr nm t + return (f,d) + +-- --------------------------------------------------------------------- + -- | Collect the free and declared variables (in the GHC.Name format) -- in a given syntax phrase t. In the result, the first list contains -- the free variables, and the second list contains the declared -- variables. --- Expects RenamedSource +-- Expects ParsedSource hsFreeAndDeclaredRdr :: (SYB.Data t) => NameMap -> t -> (FreeNames,DeclaredNames) hsFreeAndDeclaredRdr nm t = res where fd = hsFreeAndDeclaredRdr' nm t - (FN f,DN d) = fromMaybe mempty fd + (FN f,DN d) = case fd of + Left _err -> mempty + Right v -> v res = (FN (f \\ d),DN d) -hsFreeAndDeclaredRdr':: (SYB.Data t) => NameMap -> t -> Maybe (FreeNames,DeclaredNames) +hsFreeAndDeclaredRdr':: (SYB.Data t) => NameMap -> t -> Either String (FreeNames,DeclaredNames) hsFreeAndDeclaredRdr' nm t = do (FN f,DN d) <- hsFreeAndDeclared' - let (f',d') = (nub f, nub d) + -- let (f',d') = ( filter (not . GHC.isTyVarName) $ nub f + -- , filter (not . GHC.isTyVarName) $ nub d) + let (f',d') = ( nub f + , nub d) return (FN f',DN d') - -- hsFreeAndDeclared'=applyTU (stop_tdTU (failTU `adhocTU` exp where - hsFreeAndDeclared' :: Maybe (FreeNames,DeclaredNames) - hsFreeAndDeclared' = applyTU (stop_tdTU (failTU + hsFreeAndDeclared' :: Either String (FreeNames,DeclaredNames) + hsFreeAndDeclared' = applyTU (stop_tdTU (failTU `adhocTU` expr `adhocTU` pat `adhocTU` bndrs `adhocTU` binds `adhocTU` bindList `adhocTU` match + `adhocTU` stmtlist `adhocTU` stmts `adhocTU` rhs `adhocTU` ltydecl + `adhocTU` tyvarbndrs + `adhocTU` lhstyvarbndr +#if __GLASGOW_HASKELL__ > 710 + `adhocTU` lsigtype +#endif + `adhocTU` sig + `adhocTU` datadefn + `adhocTU` condecl + `adhocTU` condetails + `adhocTU` condeclfield `adhocTU` hstype )) t + -- expr -- #if __GLASGOW_HASKELL__ <= 710 expr (GHC.L l (GHC.HsVar n)) @@ -311,7 +351,7 @@ #else expr (GHC.L _ (GHC.RecordCon ln _ _ e)) = do #endif - fd <- (hsFreeAndDeclaredRdr' nm e) + fd <- hsFreeAndDeclaredRdr' nm e addFree (rdrName2NamePure nm ln) fd --Need Testing expr (GHC.L _ (GHC.EAsPat ln e)) = do @@ -329,7 +369,7 @@ -- pat -- - pat :: GHC.LPat GHC.RdrName -> Maybe (FreeNames,DeclaredNames) + pat :: GHC.LPat GHC.RdrName -> Either String (FreeNames,DeclaredNames) pat (GHC.L _ (GHC.WildPat _)) = mzero #if __GLASGOW_HASKELL__ <= 710 pat (GHC.L l (GHC.VarPat n)) @@ -338,7 +378,7 @@ #endif = return (FN [],DN [rdrName2NamePure nm (GHC.L l n)]) pat (GHC.L _ (GHC.AsPat ln p)) = do - let (f,DN d) = fromMaybe mempty $ hsFreeAndDeclaredRdr' nm p + (f,DN d) <- hsFreeAndDeclaredRdr' nm p return (f,DN (rdrName2NamePure nm ln:d)) pat (GHC.L _ (GHC.ParPat p)) = pat p @@ -396,9 +436,8 @@ -- --------------------------- - details :: GHC.HsConPatDetails GHC.RdrName -> Maybe (FreeNames,DeclaredNames) + details :: GHC.HsConPatDetails GHC.RdrName -> Either String (FreeNames,DeclaredNames) details (GHC.PrefixCon args) = do - -- logm $ "hsFreeAndDeclaredGhc.details:args=" ++ (showGhc args) fds <- mapM pat args return $ mconcat fds details (GHC.RecCon recf) = @@ -408,7 +447,7 @@ return $ mconcat fds -- Note: this one applies to HsRecFields in LPats - recfields :: (GHC.HsRecFields GHC.RdrName (GHC.LPat GHC.RdrName)) -> Maybe (FreeNames,DeclaredNames) + recfields :: (GHC.HsRecFields GHC.RdrName (GHC.LPat GHC.RdrName)) -> Either String (FreeNames,DeclaredNames) recfields (GHC.HsRecFields fields _) = do let args = map (\(GHC.L _ (GHC.HsRecField _ arg _)) -> arg) fields fds <- mapM pat args @@ -417,12 +456,12 @@ -- ----------------------- #if __GLASGOW_HASKELL__ <= 710 - bndrs :: GHC.HsWithBndrs GHC.RdrName (GHC.LHsType GHC.RdrName) -> Maybe (FreeNames,DeclaredNames) + bndrs :: GHC.HsWithBndrs GHC.RdrName (GHC.LHsType GHC.RdrName) -> Either String (FreeNames,DeclaredNames) bndrs (GHC.HsWB thing _ _ _) = do (FN ft,DN _dt) <- hsFreeAndDeclaredRdr' nm thing return (FN ft,DN []) #else - bndrs :: GHC.LHsSigWcType GHC.RdrName -> Maybe (FreeNames,DeclaredNames) + bndrs :: GHC.LHsSigWcType GHC.RdrName -> Either String (FreeNames,DeclaredNames) bndrs (GHC.HsIB _ (GHC.HsWC _ _ ty)) = do (FN ft,DN _dt) <- hsFreeAndDeclaredRdr' nm ty -- return (FN dt,DN []) @@ -461,6 +500,13 @@ (FN rf,DN rd) <- hsFreeAndDeclaredRdr' nm mrhs return (FN (pf `union` (rf \\ (pd `union` rd))),DN []) + stmtlist (ds :: [GHC.ExprLStmt GHC.RdrName]) = do + (FN f,DN d) <- recurseList ds + -- unless (null ds) $ do + -- -- error $ "hsFreeAndDeclaredRdr'.stmtlist ds=" ++ showGhc ds + -- error $ "hsFreeAndDeclaredRdr'.stmtlist (f,d)=" ++ showGhc (f,d) + return (FN (f\\d),DN d) + -- stmts -- #if __GLASGOW_HASKELL__ <= 710 stmts ((GHC.BindStmt pat' expre _bindOp _failOp) :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do @@ -470,9 +516,10 @@ -- TODO ++AZ++ : Not sure it is meaningful to pull -- anything out of bindOp/failOp (FN pf,DN pd) <- hsFreeAndDeclaredRdr' nm pat' + -- error $ "hsFreeAndDeclaredRdr'.stmts.BindStmt (pf,pd)=" ++ showGhc (pf,pd) (FN ef,_ed) <- hsFreeAndDeclaredRdr' nm expre let sf1 = [] - return (FN $ pf `union` ef `union` (sf1\\pd),DN []) -- pd) -- Check this + return (FN $ pf `union` ef `union` (sf1\\pd),DN pd) -- pd) -- Check this stmts ((GHC.LetStmt binds') :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = hsFreeAndDeclaredRdr' nm binds' @@ -481,30 +528,171 @@ -- tycldecls ----------------- - ltydecl :: GHC.TyClDecl GHC.RdrName -> Maybe (FreeNames,DeclaredNames) + ltydecl :: GHC.TyClDecl GHC.RdrName -> Either String (FreeNames,DeclaredNames) ltydecl (GHC.FamDecl fd) = hsFreeAndDeclaredRdr' nm fd ltydecl (GHC.SynDecl ln _bndrs _rhs _fvs) = return (FN [],DN [rdrName2NamePure nm ln]) #if __GLASGOW_HASKELL__ <= 710 - ltydecl (GHC.DataDecl ln _bndrs defn _fvs) = do - let dds = map (rdrName2NamePure nm) $ concatMap (GHC.con_names . GHC.unLoc) $ GHC.dd_cons defn + ltydecl (GHC.DataDecl ln tyvars defn _fvs) = do + -- let dds = map (rdrName2NamePure nm) $ concatMap (GHC.con_names . GHC.unLoc) $ GHC.dd_cons defn #else - ltydecl (GHC.DataDecl ln _bndrs defn _c _fvs) = do - let dds = map (rdrName2NamePure nm) $ concatMap (GHC.getConNames . GHC.unLoc) $ GHC.dd_cons defn + ltydecl (GHC.DataDecl ln tyvars defn _c _fvs) = do #endif - return (FN [],DN (rdrName2NamePure nm ln:dds)) - ltydecl (GHC.ClassDecl _ctx ln _tyvars - _fds _sigs meths ats atds _docs _fvs) = do - (_,md) <- hsFreeAndDeclaredRdr' nm meths - (_,ad) <- hsFreeAndDeclaredRdr' nm ats - (_,atd) <- hsFreeAndDeclaredRdr' nm atds - return (FN [],DN [rdrName2NamePure nm ln] <> md <> ad <> atd) + (FN fs,DN dds) <- hsFreeAndDeclaredRdr' nm defn + (FN _ft,DN dt) <- hsFreeAndDeclaredRdr' nm tyvars + return (FN (fs \\ dt),DN (rdrName2NamePure nm ln:dds)) + ltydecl (GHC.ClassDecl ctx ln tyvars + _fds sigs meths ats atds _docs _fvs) = do + ct <- hsFreeAndDeclaredRdr' nm ctx + (_,DN tv) <- hsFreeAndDeclaredRdr' nm tyvars + ss <- recurseList sigs + md <- hsFreeAndDeclaredRdr' nm meths + ad <- hsFreeAndDeclaredRdr' nm ats + atd <- hsFreeAndDeclaredRdr' nm atds + let (FN ff,DN df) = ((FN [],DN [rdrName2NamePure nm ln]) <> md <> ad <> atd <> ct <> ss) + return (FN (nub ff \\ tv), DN df) ------------------------------ - hstype :: GHC.LHsType GHC.RdrName -> Maybe (FreeNames,DeclaredNames) #if __GLASGOW_HASKELL__ <= 710 + tyvarbndrs :: GHC.LHsTyVarBndrs GHC.RdrName -> Either String (FreeNames,DeclaredNames) + tyvarbndrs (GHC.HsQTvs _implicit explicit) = do + recurseList explicit +#else + tyvarbndrs :: GHC.LHsQTyVars GHC.RdrName -> Either String (FreeNames,DeclaredNames) + tyvarbndrs (GHC.HsQTvs _implicit explicit _dependent ) = recurseList explicit +#endif + + lhstyvarbndr :: GHC.LHsTyVarBndr GHC.RdrName -> Either String (FreeNames,DeclaredNames) +#if __GLASGOW_HASKELL__ <= 710 + lhstyvarbndr (GHC.L l (GHC.UserTyVar n)) = return (FN [], DN [rdrName2NamePure nm (GHC.L l n)]) +#else + lhstyvarbndr (GHC.L _ (GHC.UserTyVar ln)) = return (FN [], DN [rdrName2NamePure nm ln]) +#endif + lhstyvarbndr (GHC.L _ (GHC.KindedTyVar ln lk)) = do + ks <- hsFreeAndDeclaredRdr' nm lk + return ((FN [], DN [rdrName2NamePure nm ln]) <> ks) + + ------------------------------ + +#if __GLASGOW_HASKELL__ > 710 + lsigtype :: GHC.LHsSigType GHC.RdrName -> Either String (FreeNames,DeclaredNames) + lsigtype (GHC.HsIB _ typ) = do + hsFreeAndDeclaredRdr' nm typ +#endif + + ------------------------------ + + sig :: GHC.Sig GHC.RdrName -> Either String (FreeNames,DeclaredNames) +#if __GLASGOW_HASKELL__ <= 710 + sig (GHC.TypeSig lns typ _) = do +#else + sig (GHC.TypeSig lns typ) = do +#endif + (FN ft, dt) <- hsFreeAndDeclaredRdr' nm typ + -- error $ "sig:ft=" ++ (intercalate "," $ map (\n -> showGhc n ++ (occAttributes $ GHC.occName n)) ft) + return ((FN [],DN (map (rdrName2NamePure nm ) lns)) + <> (FN (filter (not . GHC.isTyVarName) ft), dt)) +#if __GLASGOW_HASKELL__ <= 710 + sig (GHC.PatSynSig ln (_ef,GHC.HsQTvs _ns bndrs) ctx1 ctx2 typ) = do + (_, DN bs) <- hsFreeAndDeclaredRdr' nm bndrs + c1s <- hsFreeAndDeclaredRdr' nm ctx1 + c2s <- hsFreeAndDeclaredRdr' nm ctx2 + ts <- hsFreeAndDeclaredRdr' nm typ + let (FN f,DN d) = c1s <> c2s <> ts + fd = (FN (f \\ bs), DN d ) + return ((FN [],DN [rdrName2NamePure nm ln]) <> fd) +#else + sig (GHC.PatSynSig ln typ) = do + ts <- hsFreeAndDeclaredRdr' nm typ + return ((FN [],DN [rdrName2NamePure nm ln]) <> ts) +#endif +#if __GLASGOW_HASKELL__ <= 710 + sig (GHC.GenericSig lns typ) = do +#else + sig (GHC.ClassOpSig _ lns typ) = do +#endif + ts <- hsFreeAndDeclaredRdr' nm typ + return ((FN [],DN (map (rdrName2NamePure nm) lns)) <> ts) + sig (GHC.IdSig _ ) = error $ "hsFreeAndDeclaredRdr:IdSig should not occur" + sig (GHC.FixSig fsig) = hsFreeAndDeclaredRdr' nm fsig + sig (GHC.InlineSig ln _) = do + return ((FN [],DN [rdrName2NamePure nm ln]) ) + sig (GHC.SpecSig ln typs _) = do + ts <- recurseList typs + return ((FN [rdrName2NamePure nm ln],DN []) <> ts) + sig (GHC.SpecInstSig _ ssig) = hsFreeAndDeclaredRdr' nm ssig + sig (GHC.MinimalSig _ _) = return mempty + + ------------------------------ + + datadefn :: GHC.HsDataDefn GHC.RdrName -> Either String (FreeNames,DeclaredNames) + datadefn (GHC.HsDataDefn _ ctxt mtyp mkind cons mderivs) = do + cts <- mapM (hsFreeAndDeclaredRdr' nm) $ GHC.unLoc ctxt + ts <- maybeHelper mtyp + ks <- maybeHelper mkind + cs <- mapM (hsFreeAndDeclaredRdr' nm) cons + ds <- case mderivs of + Nothing -> return (FN [],DN []) + Just (GHC.L _ ds) -> recurseList ds + -- error $ "hit datadefn:[cts,ts,ks,cs,ds]=" ++ show (cts++ [ts,ks,ds] ++ cs) + return $ mconcat [mconcat cts,ts,ks,mconcat cs,ds] + + ------------------------------ + + condecl :: GHC.LConDecl GHC.RdrName -> Either String (FreeNames,DeclaredNames) +#if __GLASGOW_HASKELL__ <= 710 + condecl (GHC.L _ (GHC.ConDecl ns _expr (GHC.HsQTvs _ns bndrs) ctxt + dets res _ depc_syntax)) = + case res of + GHC.ResTyGADT ls typ -> do + (ft,_) <- hsFreeAndDeclaredRdr' nm typ + return (ft,DN (map (rdrName2NamePure nm) ns)) + GHC.ResTyH98 -> do + cs <- hsFreeAndDeclaredRdr' nm ctxt + ds <- hsFreeAndDeclaredRdr' nm dets + return ((FN [], DN (map (rdrName2NamePure nm) ns)) <> cs <> ds) +#else + condecl (GHC.L _ (GHC.ConDeclGADT ns typ _)) = do + (ft,_) <- hsFreeAndDeclaredRdr' nm typ + return (ft,DN (map (rdrName2NamePure nm) ns)) + condecl (GHC.L _ (GHC.ConDeclH98 n _ mctxt dets _)) = do + cs <- maybeHelper mctxt + ds <- hsFreeAndDeclaredRdr' nm dets + return ((FN [], DN ([rdrName2NamePure nm n])) <> cs <> ds) +#endif + + ------------------------------ + + -- condetails :: GHC.HsConDetails (GHC.LBangType GHC.RdrName) (GHC.Located [GHC.LConDeclField GHC.RdrName]) + condetails :: GHC.HsConDeclDetails GHC.RdrName -> Either String (FreeNames,DeclaredNames) + condetails (GHC.PrefixCon args) = do + -- TODO: get rid of the tyvars + (FN fs,d) <- recurseList args + return (FN (filter (not . GHC.isTyVarName) fs),d) + condetails (GHC.RecCon (GHC.L _ fs)) = recurseList fs + condetails (GHC.InfixCon a1 a2) = do + -- TODO: get rid of the tyvars + (FN fs,d) <- recurseList [a1,a2] + return (FN (filter (not . GHC.isTyVarName) fs),d) + + ------------------------------ + + condeclfield :: GHC.LConDeclField GHC.RdrName -> Either String (FreeNames,DeclaredNames) + condeclfield (GHC.L _ (GHC.ConDeclField fns typ _)) = do +#if __GLASGOW_HASKELL__ <= 710 + let ns = fns +#else + let ns = map (GHC.rdrNameFieldOcc . GHC.unLoc) fns +#endif + dt <- hsFreeAndDeclaredRdr' nm typ + return ((FN [],DN (map (rdrName2NamePure nm) ns)) <> dt) + + ------------------------------ + + hstype :: GHC.LHsType GHC.RdrName -> Either String (FreeNames,DeclaredNames) +#if __GLASGOW_HASKELL__ <= 710 hstype (GHC.L _ (GHC.HsForAllTy _ _ _ _ typ)) = hsFreeAndDeclaredRdr' nm typ #else hstype (GHC.L _ (GHC.HsForAllTy _ typ)) = hsFreeAndDeclaredRdr' nm typ @@ -539,10 +727,10 @@ hstype (GHC.L _ (GHC.HsWrapTy _ typ)) = hsFreeAndDeclaredRdr' nm typ #endif #if __GLASGOW_HASKELL__ <= 710 - hstype (GHC.L _ (GHC.HsWildcardTy)) = error "To implement: hstype, HsWildcardTy" - hstype (GHC.L _ (GHC.HsNamedWildcardTy _)) = error "To implement: HsNamedWildcardTy" + hstype (GHC.L _ (GHC.HsWildcardTy)) = return (FN [],DN []) + hstype (GHC.L l (GHC.HsNamedWildcardTy n)) = return (FN [rdrName2NamePure nm (GHC.L l n)],DN []) #else - hstype (GHC.L _ (GHC.HsWildCardTy _)) = error "To implement: hstype, HsWildcardTy" + hstype (GHC.L _ (GHC.HsWildCardTy _)) = return (FN [],DN []) #endif #if __GLASGOW_HASKELL__ > 710 hstype (GHC.L _ (GHC.HsQualTy (GHC.L _ ctxt) ty)) = recurseList (ty:ctxt) @@ -560,41 +748,17 @@ fds <- mapM (hsFreeAndDeclaredRdr' nm) xs return $ mconcat fds + maybeHelper mv = case mv of + Nothing -> return (FN [], DN []) + Just v -> hsFreeAndDeclaredRdr' nm v + ------------------------------ addFree :: GHC.Name -> (FreeNames,DeclaredNames) - -> Maybe (FreeNames,DeclaredNames) + -> Either String (FreeNames,DeclaredNames) addFree free (FN fr,de) = return (FN $ [free] `union` fr, de) - -- hsFreeAndDeclaredList :: (SYB.Data t) => [t] -> Maybe (FreeNames,DeclaredNames) - -- hsFreeAndDeclaredList l = do - -- fds <- mapM (hsFreeAndDeclaredRdr' nm) l - -- let - -- unionF (FN a) (FN b) = FN (a `union` b) - -- unionD (DN a) (DN b) = DN (a `union` b) - -- return (foldr unionF mempty (map fst fds), - -- foldr unionD mempty (map snd fds)) - --- |The same as `hsFreeAndDeclaredPNs` except that the returned --- variables are in the String format. -hsFreeAndDeclaredNameStrings::(SYB.Data t) - => t -> RefactGhc ([String],[String]) -hsFreeAndDeclaredNameStrings t = do - (f1,d1) <- hsFreeAndDeclaredPNs t - return ((nub.map showGhc) f1, (nub.map showGhc) d1) - - --- | Return the free and declared Names in the given syntax fragment. The syntax --- fragment MUST be parameterised by RdrName, else the empty list will be --- returned. -hsFreeAndDeclaredPNs :: (SYB.Data t) => t -> RefactGhc ([GHC.Name],[GHC.Name]) -hsFreeAndDeclaredPNs t = do - -- (FN f,DN d) <- hsFreeAndDeclaredGhc t - nm <- getRefactNameMap - let (FN f,DN d) = hsFreeAndDeclaredRdr nm t - return (f,d) - -- --------------------------------------------------------------------- -- |Get the names of all types declared in the given declaration @@ -700,19 +864,19 @@ -- |Find those declarations(function\/pattern binding) which define -- the specified GHC.Names. incTypeSig indicates whether the -- corresponding type signature will be included. -definingDeclsRdrNames:: +definingDeclsRdrNames :: NameMap - ->[GHC.Name] -- ^ The specified identifiers. - ->[GHC.LHsDecl GHC.RdrName] -- ^ A collection of declarations. - ->Bool -- ^ True means to include the type signature. - ->Bool -- ^ True means to look at the local declarations as well. - ->[GHC.LHsDecl GHC.RdrName] -- ^ The result. -definingDeclsRdrNames nameMap pns ds _incTypeSig recursive = concatMap defining ds --- ++AZ++:TODO: now we are processing decls again, reinstate incTypeSig function + -> [GHC.Name] -- ^ The specified identifiers. + -> [GHC.LHsDecl GHC.RdrName] -- ^ A collection of declarations. + -> Bool -- ^ True means to include the type signature. + -> Bool -- ^ True means to look at the local declarations as well. + -> [GHC.LHsDecl GHC.RdrName] -- ^ The result. +definingDeclsRdrNames nameMap pns ds incTypeSig recursive = concatMap defining ds +-- TODO: Maybe Use hsFreeAndDeclaredRdr to see what is declared in a decl. Recursive? where defining decl = if recursive - then SYB.everythingStaged SYB.Parser (++) [] ([] `SYB.mkQ` definesDecl `SYB.extQ` definesBind) decl + then SYB.everything (++) ([] `SYB.mkQ` definesDecl `SYB.extQ` definesBind) decl else definesDecl decl where definesDecl :: (GHC.LHsDecl GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName] @@ -726,6 +890,12 @@ definesDecl decl'@(GHC.L _l (GHC.ValD (GHC.PatBind _p _rhs _ty _fvs _))) | any (\n -> definesDeclRdr nameMap n decl') pns = [decl'] + definesDecl decl'@(GHC.L _l (GHC.TyClD _)) + | any (\n -> definesNameRdr nameMap n decl') pns = [decl'] + + definesDecl decl'@(GHC.L _l (GHC.SigD _)) + | incTypeSig && any (\n -> definesNameRdr nameMap n decl') pns = [decl'] + definesDecl _ = [] definesBind :: (GHC.LHsBind GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName] @@ -753,6 +923,9 @@ defines' decl'@(GHC.L _l (GHC.ValD (GHC.PatBind _p _rhs _ty _fvs _))) | any (\n -> definesDeclRdr nameMap n decl') pns = [decl'] + defines' decl'@(GHC.L _l (GHC.TyClD _)) + | any (\n -> definesDeclRdr nameMap n decl') pns = [decl'] + defines' _ = [] definesBind :: (GHC.LHsBind GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName] @@ -803,7 +976,7 @@ => NameMap -> [GHC.Name] -- ^ The specified identifiers. -> t -- ^ A collection of declarations. - ->[GHC.LTyClDecl GHC.RdrName] -- ^ The result. + -> [GHC.LTyClDecl GHC.RdrName] -- ^ The result. definingTyClDeclsNames nm pns t = defining t where defining decl @@ -825,12 +998,16 @@ | otherwise = [] #if __GLASGOW_HASKELL__ <= 710 - defines' decl'@(GHC.L _ (GHC.DataDecl pname _ _ _)) + defines' decl'@(GHC.L _ (GHC.DataDecl _ _ _ _)) #else - defines' decl'@(GHC.L _ (GHC.DataDecl pname _ _ _ _)) + defines' decl'@(GHC.L _ (GHC.DataDecl _ _ _ _ _)) #endif - | elem (GHC.nameUnique $ rdrName2NamePure nm pname) uns = [decl'] + -- elem (GHC.nameUnique $ rdrName2NamePure nm pname) uns = [decl'] + | not $ null (dus `intersect` uns) = [decl'] | otherwise = [] + where + (_,DN ds) = hsFreeAndDeclaredRdr nm decl' + dus = map GHC.nameUnique ds defines' decl'@(GHC.L _ (GHC.ClassDecl _ pname _ _ _ _ _ _ _ _)) | elem (GHC.nameUnique $ rdrName2NamePure nm pname) uns = [decl'] @@ -856,11 +1033,30 @@ = elem n (map (rdrName2NamePure nm) (hsNamessRdr p)) definesRdr _ _ _= False --- |Unwraps a LHsDecl and calls definesRdr on the result if a HsBind + +-- |Unwraps a LHsDecl and calls definesRdr on the result if a HsBind or calls clsDeclDefinesRdr if a TyClD definesDeclRdr :: NameMap -> GHC.Name -> GHC.LHsDecl GHC.RdrName -> Bool definesDeclRdr nameMap nin (GHC.L l (GHC.ValD d)) = definesRdr nameMap nin (GHC.L l d) +definesDeclRdr nameMap nin (GHC.L _ (GHC.TyClD ty)) = clsDeclDefinesRdr nameMap nin ty definesDeclRdr _ _ _ = False +-- | Return True of the type class declaration defines the +-- specified identifier +clsDeclDefinesRdr :: NameMap -> GHC.Name -> GHC.TyClDecl GHC.RdrName -> Bool +clsDeclDefinesRdr nameMap nin (GHC.SynDecl (GHC.L ln _nm) _ty _rhs _) = + case Map.lookup ln nameMap of + Nothing -> False + Just n -> GHC.nameUnique n == GHC.nameUnique nin +clsDeclDefinesRdr _ _ _ = False + +-- | Returns True if the provided Name is defined in the LHsDecl +definesNameRdr :: NameMap -> GHC.Name -> GHC.LHsDecl GHC.RdrName -> Bool +definesNameRdr nameMap nin (GHC.L l (GHC.ValD d)) = definesRdr nameMap nin (GHC.L l d) +definesNameRdr nameMap nin d = nin `elem` declared + where + (_,DN declared) = hsFreeAndDeclaredRdr nameMap d +-- definesDeclRdr _ _ _ = False + -- --------------------------------------------------------------------- -- | Return True if the declaration defines the type signature of the @@ -940,6 +1136,8 @@ -- return []. hsVisibleDsRdr :: (SYB.Data t) => NameMap -> GHC.Name -> t -> RefactGhc DeclaredNames +-- TODO: DeclaredNames is probably the wrong type. Perhaps create VisibleNames +-- And perhaps use a NameSet or Set, to avoid the nub call hsVisibleDsRdr nm e t = do -- logm $ "hsVisibleDsRdr:(e,t)=" ++ (SYB.showData SYB.Renamer 0 (e,t)) (DN d) <- res @@ -950,6 +1148,7 @@ -- in terms of sub-elements. Hence as an optimisation, -- consider calling the relevent element directly, instead -- of looping back into the main function. + -- OR, use a more effective recursion scheme res = (const err -- (DN []) `SYB.extQ` parsed `SYB.extQ` lvalbinds @@ -961,6 +1160,7 @@ `SYB.extQ` hsbind `SYB.extQ` hslocalbinds `SYB.extQ` lmatch + `SYB.extQ` match `SYB.extQ` grhss `SYB.extQ` lgrhs `SYB.extQ` lexpr @@ -968,7 +1168,10 @@ `SYB.extQ` tyclgroup `SYB.extQ` tycldeclss `SYB.extQ` tycldecls + `SYB.extQ` ltycldecl `SYB.extQ` tycldecl + `SYB.extQ` hsdatadefn + `SYB.extQ` condecl `SYB.extQ` instdecls `SYB.extQ` instdecl `SYB.extQ` lhstype @@ -982,6 +1185,7 @@ `SYB.extQ` ibndrs `SYB.extQ` lsigty #endif + `SYB.extQ` lanndecl ) t -- err2 = error $ "hsVisibleDsRdr:err2:no match for:" ++ (SYB.showData SYB.Renamer 0 t) @@ -990,9 +1194,9 @@ parsed p | findNameInRdr nm e p = do -- dfds <- mapM (hsVisibleDsRdr nm e) $ GHC.hsmodDecls $ GHC.unLoc p - logm $ "hsVisibleDsRdr parsedSource:decls starting" + -- logm $ "hsVisibleDsRdr parsedSource:decls starting" dfds <- mapM (declFun ( hsVisibleDsRdr nm e) ) $ GHC.hsmodDecls $ GHC.unLoc p - logm $ "hsVisibleDsRdr parsedSource:decls done" + -- logm $ "hsVisibleDsRdr parsedSource:decls done" return $ mconcat dfds parsed _ = return (DN []) @@ -1009,11 +1213,11 @@ return $ mconcat fdss <> mconcat fdsb valbinds vb@(GHC.ValBindsOut _binds _sigs) | findNameInRdr nm e vb = do - logm $ "hsVisibleDsRdr valbinds:ValBindsOut:impossible for RdrName" + -- logm $ "hsVisibleDsRdr valbinds:ValBindsOut:impossible for RdrName" return (DN []) valbinds _ = do - logm $ "hsVisibleDsRdr nm.valbinds:not matched" + -- logm $ "hsVisibleDsRdr nm.valbinds:not matched" return (DN []) lhsdecls :: [GHC.LHsDecl GHC.RdrName] -> RefactGhc DeclaredNames @@ -1025,7 +1229,7 @@ lhsdecl :: GHC.LHsDecl GHC.RdrName -> RefactGhc DeclaredNames lhsdecl (GHC.L l dd) = do - logm $ "hsVisibleDsRdr.lhsdecl" + -- logm $ "hsVisibleDsRdr.lhsdecl" case dd of GHC.TyClD d -> hsVisibleDsRdr nm e (GHC.L l d) GHC.InstD d -> hsVisibleDsRdr nm e (GHC.L l d) @@ -1065,10 +1269,8 @@ #endif | findNameInRdr nm e matches = do fds <- mapM (hsVisibleDsRdr nm e) matches - logm $ "hsVisibleDsRdr.hsbind:fds=" ++ show fds return $ mconcat fds hsbind _ = do - -- logm $ "hsVisibleDsRdr.hsbind:miss" return (DN []) @@ -1081,35 +1283,41 @@ hslocalbinds _ = return (DN []) lmatch :: (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) -> RefactGhc DeclaredNames - lmatch (GHC.L _ (GHC.Match _fn pats _mtyp rhs)) - | findNameInRdr nm e pats = do - logm $ "hsVisibleDsRdr nm.lmatch:in pats=" - return (DN []) -- TODO: extend this - | findNameInRdr nm e rhs = do - logm $ "hsVisibleDsRdr nm.lmatch:doing rhs" - let (pf,pd) = hsFreeAndDeclaredRdr nm pats - logm $ "hsVisibleDsRdr nm.lmatch:(pf,pd)=" ++ (show (pf,pd)) - ( rd) <- hsVisibleDsRdr nm e rhs + lmatch (GHC.L _ m) = match m + + match :: (GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) -> RefactGhc DeclaredNames + match (GHC.Match _fn pats _mtyp rhs) + | findNameInRdr nm e rhs || findNameInRdr nm e pats = do + -- logm $ "hsVisibleDsRdr nm.lmatch:doing rhs" + let (_pf,pd) = hsFreeAndDeclaredRdr nm pats + -- logm $ "hsVisibleDsRdr nm.lmatch:(pf,pd)=" ++ (show (_pf,pd)) + rd <- hsVisibleDsRdr nm e rhs + -- logm $ "hsVisibleDsRdr nm.lmatch:rd=" ++ (show rd) return (pd <> rd) - lmatch _ =return (DN []) + match _ =return (DN []) grhss :: (GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)) -> RefactGhc DeclaredNames grhss (GHC.GRHSs guardedRhss lstmts') - | findNameInRdr nm e guardedRhss = do - logm "hsVisibleDsRdr nm.grhss:about to do grhss" + | findNameInRdr nm e guardedRhss || findNameInRdr nm e lstmts' = do + -- logm "hsVisibleDsRdr nm.grhss:about to do lstmts" fds <- mapM (hsVisibleDsRdr nm e) guardedRhss - logm "hsVisibleDsRdr nm.grhss:grhss done" - return $ mconcat fds - | findNameInRdr nm e lstmts' = do - logm "hsVisibleDsRdr nm.grhss:about to do lstmts" - hsVisibleDsRdr nm e lstmts' - grhss _ = return (DN []) + -- sfds <- hsVisibleDsRdr nm e lstmts' + let (_,sfds) = hsFreeAndDeclaredRdr nm lstmts' + return $ mconcat (sfds:fds) + grhss _ = do + -- logm $ "hsVisibleDsRdr.grhss: no match" + return (DN []) lgrhs :: GHC.LGRHS GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc DeclaredNames lgrhs (GHC.L _ (GHC.GRHS guards ex)) - | findNameInRdr nm e guards = logm "hsVisibleDsRdr nm.lgrhs.guards" >> hsVisibleDsRdr nm e guards - | findNameInRdr nm e ex = logm "hsVisibleDsRdr nm.lgrhs.ex" >> hsVisibleDsRdr nm e ex - lgrhs _ = return (DN []) + | findNameInRdr nm e guards = hsVisibleDsRdr nm e guards + | findNameInRdr nm e ex = do + r <- hsVisibleDsRdr nm e ex + -- logm $ "hsVisibleDsRdr.lgrhs:r=" ++ show r + return r + lgrhs _ = do + -- logm $ "hsVisibleDsRdr.lgrhs: no match" + return (DN []) lexpr :: GHC.LHsExpr GHC.RdrName -> RefactGhc DeclaredNames @@ -1119,26 +1327,25 @@ lexpr (GHC.L l (GHC.HsVar (GHC.L _ n))) #endif | findNameInRdr nm e n = do - logm $ "hsVisibleDsRdr.lexpr.HsVar entity found" + -- logm $ "hsVisibleDsRdr.lexpr.HsVar entity found" return (DN [rdrName2NamePure nm (GHC.L l n)]) lexpr (GHC.L _ (GHC.HsLet lbinds expr)) | findNameInRdr nm e lbinds || findNameInRdr nm e expr = do - logm $ "hsVisibleDsRdr.lexpr.HsLet entity found" + -- logm $ "hsVisibleDsRdr.lexpr.HsLet entity found" let (_,lds) = hsFreeAndDeclaredRdr nm lbinds let (_,eds) = hsFreeAndDeclaredRdr nm expr return $ lds <> eds lexpr expr | findNameInRdr nm e expr = do - logm $ "hsVisibleDsRdr nm.lexpr.(e,expr):" ++ (showGhc (e,expr)) - let (FN efs,_) = hsFreeAndDeclaredRdr nm expr + -- logm $ "hsVisibleDsRdr nm.lexpr.(e,expr):" ++ (showGhc (e,expr)) + let (FN efs,eds) = hsFreeAndDeclaredRdr nm expr let (FN _eefs,DN eeds) = hsFreeAndDeclaredRdr nm e - logm $ "hsVisibleDsRdr nm.lexpr done" - -- return (DN e1fs <> DN eofs <> DN e2fs) - return (DN (efs \\ eeds)) + -- logm $ "hsVisibleDsRdr nm.lexpr (efs,_d,_eefs,eeds) " ++ show (efs,_d,_eefs,eeds) + return (DN (efs \\ eeds) <> eds) lexpr x = do - logm $ "hsVisibleDsRdr.lexpr:miss for:" ++ SYB.showData SYB.Parser 0 x + -- logm $ "hsVisibleDsRdr.lexpr:miss for:" ++ SYB.showData SYB.Parser 0 x return (DN []) -- --------------------------------- @@ -1167,21 +1374,38 @@ tycldecls :: [GHC.LTyClDecl GHC.RdrName] -> RefactGhc DeclaredNames tycldecls tcds | findNameInRdr nm e tcds = do - logm $ "hsVisibleDsRdr.tycldecls" fds <- mapM (hsVisibleDsRdr nm e) tcds - logm $ "hsVisibleDsRdr.tycldecls done" return $ mconcat fds tycldecls _ = return (DN []) - tycldecl :: GHC.LTyClDecl GHC.RdrName -> RefactGhc DeclaredNames + ltycldecl :: GHC.LTyClDecl GHC.RdrName -> RefactGhc DeclaredNames + ltycldecl tcd + | findNameInRdr nm e tcd = do + let (_,ds) = hsFreeAndDeclaredRdr nm tcd + return ds + ltycldecl _ = return (DN []) + + tycldecl :: GHC.TyClDecl GHC.RdrName -> RefactGhc DeclaredNames tycldecl tcd | findNameInRdr nm e tcd = do - logm $ "hsVisibleDsRdr.tycldecl" let (_,ds) = hsFreeAndDeclaredRdr nm tcd - logm $ "hsVisibleDsRdr.tycldecl done" return ds tycldecl _ = return (DN []) + hsdatadefn :: GHC.HsDataDefn GHC.RdrName -> RefactGhc DeclaredNames + hsdatadefn tcd + | findNameInRdr nm e tcd = do + let (_,ds) = hsFreeAndDeclaredRdr nm tcd + return ds + hsdatadefn _ = return (DN []) + + condecl :: GHC.ConDecl GHC.RdrName -> RefactGhc DeclaredNames + condecl tcd + | findNameInRdr nm e tcd = do + let (_,ds) = hsFreeAndDeclaredRdr nm tcd + return ds + condecl _ = return (DN []) + -- --------------------------------- instdecls :: [GHC.LInstDecl GHC.RdrName] -> RefactGhc DeclaredNames @@ -1219,7 +1443,7 @@ = return (DN []) lhstype (GHC.L _ (GHC.HsFunTy{})) = return (DN []) lhstype ty = do - logm $ "lshtype: TypeUtils 1588" ++ SYB.showData SYB.Renamer 0 ty + -- logm $ "lshtype: TypeUtils 1588" ++ SYB.showData SYB.Renamer 0 ty return (DN []) -- ----------------------- @@ -1342,7 +1566,6 @@ fds <- mapM lpat ps return $ mconcat fds lpat (GHC.L _ (GHC.ConPatIn n det)) = do - -- logm $ "hsFreeAndDeclaredGhc.lpat.ConPatIn:details=" ++ (SYB.showData SYB.Renamer 0 det) (DN d) <- details det return $ (DN (rdrName2NamePure nm n:d)) -- lpat (GHC.ConPatOut ) @@ -1382,7 +1605,6 @@ details :: GHC.HsConPatDetails GHC.RdrName -> RefactGhc DeclaredNames details (GHC.PrefixCon args) = do - -- logm $ "hsFreeAndDeclaredGhc.details:args=" ++ (showGhc args) fds <- mapM lpat args return $ mconcat fds details (GHC.RecCon recf) = @@ -1407,6 +1629,9 @@ lsigty (GHC.HsIB _ ty) = hsVisibleDsRdr nm e ty #endif -- ----------------------- + lanndecl :: GHC.LAnnDecl GHC.RdrName -> RefactGhc DeclaredNames + lanndecl (GHC.L _ (GHC.HsAnnotation _ _ expr)) = hsVisibleDsRdr nm e expr + -- ----------------------- err = error $ "hsVisibleDsRdr nm:no match for:" ++ (SYB.showData SYB.Parser 0 t) @@ -1549,6 +1774,13 @@ eqRdrNamePure :: NameMap -> GHC.Located GHC.RdrName -> GHC.Name -> Bool eqRdrNamePure nameMap rn n = GHC.nameUnique (rdrName2NamePure nameMap rn) == GHC.nameUnique n + +-- --------------------------------------------------------------------- + +-- | Returns True if both @GHC.Name@s are in the same @GHC.NameSpace@. +sameNameSpace :: GHC.Name -> GHC.Name -> Bool +sameNameSpace n1 n2 + = (GHC.occNameSpace $ GHC.nameOccName n1) == (GHC.occNameSpace $ GHC.nameOccName n2) -- --------------------------------------------------------------------- diff --git a/src/MainHaRe.hs b/src/MainHaRe.hs deleted file mode 100644 --- a/src/MainHaRe.hs +++ /dev/null @@ -1,312 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -import Control.Exception -import Control.Monad.Writer.Lazy -import Data.List -import Data.Version -import Development.GitRev (gitCommitCount) -import Distribution.System (buildArch) -import Distribution.Text (display) -import Language.Haskell.Refact.API -import Language.Haskell.Refact.HaRe -import Options.Applicative.Simple -import qualified Language.Haskell.GhcMod as GM -import qualified Paths_HaRe as Meta - --- temporary until exposed by ghc-mod --- import Options -import Language.Haskell.GhcMod.Options.Options - -main :: IO () -main = do - -- Version code from stack. Maybe move this stuff into optparse-simple ? - let commitCount = $gitCommitCount - versionString' = concat $ concat - [ [$(simpleVersion Meta.version)] - -- Leave out number of commits for --depth=1 clone - -- See https://github.com/commercialhaskell/stack/issues/792 - , [" (" ++ commitCount ++ " commits)" | commitCount /= ("1"::String) && - commitCount /= ("UNKNOWN" :: String)] - , [" ", display buildArch] - ] - numericVersion :: Parser (a -> a) - numericVersion = - infoOption - (showVersion Meta.version) - (long "numeric-version" <> - help "Show only version number") - -- Parse the options and run the specified command. - (global, run) <- - simpleOptions - versionString' - "HaRe - the haskell refactorer" - "" - -- (numericVersion <*> globalOptsParser) $ - (numericVersion <*> allOptsParser) $ - do - addCommand "demote" - "Demote a declaration" - runCmd - demoteCmdOpts - - addCommand "dupdef" - "Duplicate a definition" - runCmd - dupDefCmdOpts - - addCommand "iftocase" - "Convert an if statement to a case statement" - runCmd - ifToCaseCmdOpts - - addCommand "liftOneLevel" - "Lift a definition up one level" - runCmd - liftOneLevelCmdOpts - - addCommand "liftToTopLevel" - "Lift a definition to the top level" - runCmd - liftToTopLevelCmdOpts - - addCommand "rename" - "Rename an identifier" - runCmd - renameCmdOpts - - addCommand "addOneParam" - "Add a new parameter to a function in first position" - runCmd - addOneParamCmdOpts - - addCommand "rmOneParam" - "Remove a new parameter from a function" - runCmd - rmOneParamCmdOpts - run global - --- --------------------------------------------------------------------- - -type Row = Int -type Col = Int - -data HareParams = DemoteCmd FilePath Row Col - | DupDefCmd FilePath String Row Col - | IfToCaseCmd FilePath Row Col Row Col - | LiftOneLevel FilePath Row Col - | LiftToTopLevel FilePath Row Col - | RenameCmd FilePath String Row Col - | AddOneParam FilePath String Row Col - | RmOneParam FilePath Row Col - deriving Show - -runCmd :: HareParams -> (RefactSettings,GM.Options) -> IO () -runCmd (DemoteCmd fileName r c) (opt, gOpt) - = runFunc $ demote opt gOpt fileName (r,c) - -runCmd (DupDefCmd fileName newname r c) (opt, gOpt) - = runFunc $ duplicateDef opt gOpt fileName newname (r,c) - -runCmd (IfToCaseCmd fileName sr sc er ec) (opt, gOpt) - = runFunc $ ifToCase opt gOpt fileName (sr,sc) (er,ec) - -runCmd (LiftOneLevel fileName r c) (opt, gOpt) - = runFunc $ liftOneLevel opt gOpt fileName (r,c) - -runCmd (LiftToTopLevel fileName r c) (opt, gOpt) - = runFunc $ liftToTopLevel opt gOpt fileName (r,c) - -runCmd (RenameCmd fileName newname r c) (opt, gOpt) - = runFunc $ rename opt gOpt fileName newname (r,c) - -runCmd (AddOneParam fileName newname r c) (opt, gOpt) - = runFunc $ addOneParameter opt gOpt fileName newname (r,c) - -runCmd (RmOneParam fileName r c) (opt, gOpt) - = runFunc $ rmOneParameter opt gOpt fileName (r,c) - --- --------------------------------------------------------------------- - -rmOneParamCmdOpts :: Parser HareParams -rmOneParamCmdOpts = - LiftOneLevel - <$> strArgument - ( metavar "FILE" - <> help "Specify Haskell file to process" - ) - <*> argument auto - ( metavar "line" - <> help "The line the function name is on") - <*> argument auto - ( metavar "col" - <> help "The col the function name starts at") - --- --------------------------------------------------------------------- - -addOneParamCmdOpts :: Parser HareParams -addOneParamCmdOpts = - AddOneParam - <$> strArgument - ( metavar "FILE" - <> help "Specify Haskell file to process" - ) - <*> strArgument - ( metavar "NAME" - <> help "The name for the parameter" - ) - <*> argument auto - ( metavar "line" - <> help "The line the function name is on") - <*> argument auto - ( metavar "col" - <> help "A col inside the function name name") - --- --------------------------------------------------------------------- - -renameCmdOpts :: Parser HareParams -renameCmdOpts = - RenameCmd - <$> strArgument - ( metavar "FILE" - <> help "Specify Haskell file to process" - ) - <*> strArgument - ( metavar "NEWNAME" - <> help "The new name for the identifier" - ) - <*> argument auto - ( metavar "line" - <> help "The line the identifier is on") - <*> argument auto - ( metavar "col" - <> help "A col inside the identifier name") - --- --------------------------------------------------------------------- - -liftToTopLevelCmdOpts :: Parser HareParams -liftToTopLevelCmdOpts = - LiftOneLevel - <$> strArgument - ( metavar "FILE" - <> help "Specify Haskell file to process" - ) - <*> argument auto - ( metavar "line" - <> help "The line the declaration is on") - <*> argument auto - ( metavar "col" - <> help "The col the declaration starts at") - --- --------------------------------------------------------------------- - -liftOneLevelCmdOpts :: Parser HareParams -liftOneLevelCmdOpts = - LiftOneLevel - <$> strArgument - ( metavar "FILE" - <> help "Specify Haskell file to process" - ) - <*> argument auto - ( metavar "line" - <> help "The line the declaration is on") - <*> argument auto - ( metavar "col" - <> help "The col the declaration starts at") - --- --------------------------------------------------------------------- - -ifToCaseCmdOpts :: Parser HareParams -ifToCaseCmdOpts = - IfToCaseCmd - <$> strArgument - ( metavar "FILE" - <> help "Specify Haskell file to process" - ) - <*> argument auto - ( metavar "startline" - <> help "The line the if statement starts on") - <*> argument auto - ( metavar "startcol" - <> help "The col the if statement starts at") - - <*> argument auto - ( metavar "endline" - <> help "The line the if statement ends on") - <*> argument auto - ( metavar "endcol" - <> help "The col the if statement ends at") - --- --------------------------------------------------------------------- - -demoteCmdOpts :: Parser HareParams -demoteCmdOpts = - DemoteCmd - <$> strArgument - ( metavar "FILE" - <> help "Specify Haskell file to process" - ) - <*> argument auto - ( metavar "line" - <> help "The line the declaration is on") - <*> argument auto - ( metavar "col" - <> help "The col the declaration starts at") - --- --------------------------------------------------------------------- - -dupDefCmdOpts :: Parser HareParams -dupDefCmdOpts = - DupDefCmd - <$> strArgument - ( metavar "FILE" - <> help "Specify Haskell file to process" - ) - <*> strArgument - ( metavar "NEWNAME" - <> help "The name for the new definition" - ) - <*> argument auto - ( metavar "line" - <> help "The line the definition is on") - <*> argument auto - ( metavar "col" - <> help "A col inside the definition name") - - --- --------------------------------------------------------------------- - -allOptsParser :: Parser (RefactSettings,GM.Options) -allOptsParser = (,) <$> globalOptsParser <*> globalArgSpec - -globalOptsParser :: Parser RefactSettings -globalOptsParser = mkRefSet - <$> ((\b -> if b then Debug else Normal) <$> switch - ( long "debug" - <> short 'd' - <> help "Generate debug output" )) - where - mkRefSet v = RefSet v (True,True,True,True) - --- --------------------------------------------------------------------- - --- | Return the result of an Either as a sexp for emacs etc. -runFunc :: IO [String] -> IO () -runFunc f = do - r <- catchException f - let ret = case r of - Left s -> "(error " ++ (show s) ++ ")" - Right mfs -> "(ok " ++ showLisp mfs ++ ")" - putStrLn ret - -showLisp :: [String] -> String -showLisp xs = "(" ++ (intercalate " " $ map show xs) ++ ")" - -catchException :: (IO t) -> IO (Either String t) -catchException f = do - res <- handle handler (f >>= \r -> return $ Right r) - return res - where - handler:: SomeException -> IO (Either String t) - handler e = return (Left (stripCallStack $ show e)) diff --git a/test/CaseSpec.hs b/test/CaseSpec.hs --- a/test/CaseSpec.hs +++ b/test/CaseSpec.hs @@ -56,8 +56,7 @@ r' `shouldBe` ["Case/C.hs"] diff <- compareFiles "./test/testdata/Case/C.refactored.hs" "./test/testdata/Case/C.hs.expected" - -- diff `shouldBe` [] - pendingWith "sort out alignment after RigidLayout introduced in ghc-exactprint" + diff `shouldBe` [] -- --------------------------------- @@ -68,8 +67,7 @@ r' `shouldBe` ["Case/D.hs"] diff <- compareFiles "./test/testdata/Case/D.refactored.hs" "./test/testdata/Case/D.hs.expected" - -- diff `shouldBe` [] - pendingWith "sort out alignment after RigidLayout introduced in ghc-exactprint" + diff `shouldBe` [] -- --------------------------------- @@ -80,8 +78,7 @@ r' `shouldBe` ["Case/E.hs"] diff <- compareFiles "./test/testdata/Case/E.refactored.hs" "./test/testdata/Case/E.hs.expected" - -- diff `shouldBe` [] - pendingWith "sort out alignment after RigidLayout introduced in ghc-exactprint" + diff `shouldBe` [] -- --------------------------------- @@ -92,8 +89,7 @@ r' `shouldBe` ["Case/F.hs"] diff <- compareFiles "./test/testdata/Case/F.refactored.hs" "./test/testdata/Case/F.hs.expected" - -- diff `shouldBe` [] - pendingWith "sort out alignment after RigidLayout introduced in ghc-exactprint" + diff `shouldBe` [] -- --------------------------------- diff --git a/test/DeleteDefSpec.hs b/test/DeleteDefSpec.hs new file mode 100644 --- /dev/null +++ b/test/DeleteDefSpec.hs @@ -0,0 +1,41 @@ +module DeleteDefSpec (main, spec) where + + +import Test.Hspec +import Language.Haskell.Refact.Refactoring.DeleteDef +import System.Directory +import TestUtils + +main :: IO () +main = do + hspec spec + +spec :: Spec +spec = do + describe "doDeleteDef" $ do + it "removes a small definition from the top level of a function" $ do + res <- ct $ deleteDef defaultTestSettings testOptions "./DeleteDef/Dd1.hs" (5,1) + res' <- ct $ mapM makeRelativeToCurrentDirectory res + res' `shouldBe` ["DeleteDef/Dd1.hs"] + diff <- ct $ compareFiles "./DeleteDef/Dd1.refactored.hs" + "./DeleteDef/Dd1.hs.expected" + diff `shouldBe` [] + it "checks that a definition used in another module is not deleted" $ do + res <- ct $ catchException (deleteDef defaultTestSettings testOptions "./DeleteDef/Dd2.hs" (4,1)) + (show res) `shouldBe` "Just \"The def to be deleted is still being used\"" + it "checks that a definition used in the same module is not deleted" $ do + res <- ct $ catchException (deleteDef defaultTestSettings testOptions "./DeleteDef/Dd3.hs" (4,1)) + (show res) `shouldBe` "Just \"The def to be deleted is still being used\"" + it "checks that a recursive definition can be deleted" $ do + res <- ct $ deleteDef defaultTestSettings testOptions "./DeleteDef/Dd1.hs" (21,1) + res' <- ct $ mapM makeRelativeToCurrentDirectory res + res' `shouldBe` ["DeleteDef/Dd1.hs"] + diff <- ct $ compareFiles "./DeleteDef/Dd1.refactored.hs" + "./DeleteDef/Dd1.hs.expected2" + diff `shouldBe` [] + it "checks possible bug found by tests in unwrap type synonym" $ do + res <- ct $ deleteDef defaultTestSettings testOptions "./DeleteDef/UTS1.hs" (3,6) + res' <- ct $ mapM makeRelativeToCurrentDirectory res + res' `shouldBe` ["DeleteDef/UTS1.hs"] + diff <- ct $ compareFiles "./DeleteDef/UTS1.hs.expected" "./DeleteDef/UTS1.refactored.hs" + diff `shouldBe` [] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Monad +import TestUtils +import qualified Turtle as Tu +import qualified Control.Foldl as Fold + +import Test.Hspec.Runner +import qualified Spec + +-- --------------------------------------------------------------------- + +main :: IO () +main = do + cleanupDirs (Tu.ends "/.stack-work") + cleanupDirs (Tu.ends "/dist") + setupStackFiles + hspec Spec.spec + +-- --------------------------------------------------------------------- + +setupStackFiles :: IO () +setupStackFiles = + forM_ stackFiles $ \f -> + writeFile f stackFileContents + +-- --------------------------------------------------------------------- + +stackFiles :: [FilePath] +stackFiles = + [ "./test/testdata/stack.yaml" + , "./test/testdata/cabal/cabal3/stack.yaml" + , "./test/testdata/cabal/foo/stack.yaml" + , "./test/testdata/cabal/cabal4/stack.yaml" + , "./test/testdata/cabal/cabal1/stack.yaml" + , "./test/testdata/cabal/cabal2/stack.yaml" + ] + + +-- |Choose a resolver based on the current compiler, otherwise HaRe/ghc-mod will +-- not be able to load the files +resolver :: String +resolver = +#if __GLASGOW_HASKELL__ > 710 + "resolver: nightly-2016-08-25" +#else + "resolver: lts-6.13" +#endif + +-- --------------------------------------------------------------------- +{- + +resolver: lts-6.13 +# resolver: nightly-2016-08-25 +packages: +- '.' +extra-deps: [] +-} +stackFileContents :: String +stackFileContents = unlines + [ "# WARNING: THIS FILE IS AUTOGENERATED IN test/Main.hs. IT WILL BE OVERWRITTEN ON EVERY TEST RUN" + , resolver + , "packages:" + , "- '.'" + , "extra-deps: " + , "- conversion-1.2.1" + , "- conversion-bytestring-1.0.1" + , "- conversion-case-insensitive-1.0.0.0" + , "- conversion-text-1.0.1" + ] + +-- --------------------------------------------------------------------- + +cleanupDirs :: Tu.Pattern t -> IO () +cleanupDirs ending = do + dirs <- getDirs ending + forM_ dirs $ \dir -> Tu.rmtree dir + +getDirs :: Tu.Pattern t -> IO [Tu.FilePath] +getDirs ending = do + let + -- dirs = Tu.find (Tu.ends "/.stack-work") "./test" + dirs = Tu.find ending "./test" + Tu.fold dirs Fold.list + +listStackDirs :: IO () +listStackDirs = Tu.sh $ do + dirs <- Tu.find (Tu.ends "/.stack-work") "./test" + mapM Tu.echo $ Tu.textToLines $ "found:" Tu.<> (Tu.repr dirs) + diff --git a/test/MoveDefSpec.hs b/test/MoveDefSpec.hs --- a/test/MoveDefSpec.hs +++ b/test/MoveDefSpec.hs @@ -20,7 +20,7 @@ describe "liftToTopLevel" $ do it "cannot lift a top level declaration" $ do - -- res <- catchException (liftToTopLevel logTestSettings testOptions "./test/testdata/MoveDef/Md1.hs" (4,1)) + -- res <- catchException (ct $ liftToTopLevel logTestSettings testOptions "./MoveDef/Md1.hs" (4,1)) res <- catchException (ct $ liftToTopLevel defaultTestSettings testOptions "./MoveDef/Md1.hs" (4,1)) (show res) `shouldBe` "Just \"\\nThe identifier is not a local function/pattern name!\"" @@ -28,8 +28,8 @@ it "checks for name clashes" $ do -- res <- catchException (doLiftToTopLevel ["./test/testdata/MoveDef/Md1.hs","17","5"]) - res <- catchException (liftToTopLevel defaultTestSettings testOptions "./test/testdata/MoveDef/Md1.hs" (17,5)) - (show res) `shouldBe` "Just \"The identifier(s): (ff, test/testdata/MoveDef/Md1.hs:17:5) will cause name clash/capture or ambiguity occurrence problem after lifting, please do renaming first!\"" + res <- catchException (ct $ liftToTopLevel defaultTestSettings testOptions "./MoveDef/Md1.hs" (17,5)) + (show res) `shouldBe` "Just \"The identifier(s): (ff, MoveDef/Md1.hs:17:5) will cause name clash/capture or ambiguity occurrence problem after lifting, please do renaming first!\"" {- it "checks for invalid new name" $ do @@ -44,8 +44,8 @@ -- --------------------------------- it "lifts a definition to the top level" $ do - r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/MoveDef/Md1.hs" (24,5) - -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/MoveDef/Md1.hs" (24,5) + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./MoveDef/Md1.hs" (24,5) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./test/testdata/MoveDef/Md1.hs" (24,5) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/MoveDef/Md1.hs\"]" diff <- compareFiles "./test/testdata/MoveDef/Md1.hs.expected" @@ -92,7 +92,7 @@ -- --------------------------------- it "liftToTopLevel D3 C3 A3 8 6" $ do - r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/D3.hs" (8,6) + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/D3.hs" (8,6) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/D3.hs\"]" diff <- compareFiles "./test/testdata/LiftToToplevel/D3.hs.expected" @@ -109,8 +109,8 @@ -- --------------------------------- it "liftToTopLevel WhereIn1 12 18" $ do - r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/WhereIn1.hs" (12,18) - -- r <- liftToTopLevel logTestSettings testOptions Nothing "./test/testdata/LiftToToplevel/WhereIn1.hs" (12,18) + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/WhereIn1.hs" (12,18) + -- r <- ct $ liftToTopLevel logTestSettings testOptions Nothing "./test/testdata/LiftToToplevel/WhereIn1.hs" (12,18) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/WhereIn1.hs\"]" diff <- compareFiles "./test/testdata/LiftToToplevel/WhereIn1.hs.expected" @@ -121,8 +121,8 @@ -- --------------------------------- it "liftToTopLevel WhereIn6 13 29" $ do - r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/WhereIn6.hs" (13,29) - -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/WhereIn6.hs" (13,29) + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/WhereIn6.hs" (13,29) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/WhereIn6.hs" (13,29) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/WhereIn6.hs\"]" diff <- compareFiles "./test/testdata/LiftToToplevel/WhereIn6.hs.expected" @@ -133,8 +133,8 @@ -- --------------------------------- it "liftToTopLevel WhereIn7 12 14" $ do - r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/WhereIn7.hs" (12,14) - -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/WhereIn7.hs" (12,14) + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/WhereIn7.hs" (12,14) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/WhereIn7.hs" (12,14) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/WhereIn7.hs\"]" diff <- compareFiles "./test/testdata/LiftToToplevel/WhereIn7.hs.expected" @@ -144,8 +144,8 @@ -- --------------------------------- it "liftToTopLevel LetIn1 11 22" $ do - r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/LetIn1.hs" (11,22) - -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/LetIn1.hs" (11,22) + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/LetIn1.hs" (11,22) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/LetIn1.hs" (11,22) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/LetIn1.hs\"]" diff <- compareFiles "./test/testdata/LiftToToplevel/LetIn1.hs.expected" @@ -156,8 +156,8 @@ -- --------------------------------- it "liftToTopLevel LetIn2 10 22" $ do - r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/LetIn2.hs" (10,22) - -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/LetIn2.hs" (10,22) + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/LetIn2.hs" (10,22) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/LetIn2.hs" (10,22) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/LetIn2.hs\"]" diff <- compareFiles "./test/testdata/LiftToToplevel/LetIn2.hs.expected" @@ -168,8 +168,8 @@ -- --------------------------------- it "liftToTopLevel LetIn3 10 27" $ do - r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/LetIn3.hs" (10,27) - -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/LetIn3.hs" (10,27) + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/LetIn3.hs" (10,27) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/LetIn3.hs" (10,27) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/LetIn3.hs\"]" diff <- compareFiles "./test/testdata/LiftToToplevel/LetIn3.hs.expected" @@ -178,32 +178,52 @@ -- --------------------------------- +{- + This is trying to test an invalid lift + it "liftToTopLevel PatBindIn1 18 7" $ do - r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/PatBindIn1.hs" (18,7) - -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/PatBindIn1.hs" (18,7) + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/PatBindIn1.hs" (18,7) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/PatBindIn1.hs" (18,7) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/PatBindIn1.hs\"]" diff <- compareFiles "./test/testdata/LiftToToplevel/PatBindIn1.hs.expected" "./test/testdata/LiftToToplevel/PatBindIn1.refactored.hs" diff `shouldBe` [] +-} -- --------------------------------- + it "liftToTopLevel PatBindIn2 17 7 fails" $ do + res <- catchException (ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/PatBindIn2.hs" (17,7)) + -- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/PatBindIn2.hs" (17,7) + + (show res) `shouldBe` "Just \"Cannot lift a declaration assigning to a tuple pattern\"" + + -- --------------------------------- + it "liftToTopLevel PatBindIn3 11 15" $ do - r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/PatBindIn3.hs" (11,15) - -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/PatBindIn3.hs" (11,15) + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/PatBindIn3.hs" (11,15) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/PatBindIn3.hs" (11,15) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/PatBindIn3.hs\"]" diff <- compareFiles "./test/testdata/LiftToToplevel/PatBindIn3.hs.expected" "./test/testdata/LiftToToplevel/PatBindIn3.refactored.hs" diff `shouldBe` [] + -- --------------------------------- + it "liftToTopLevel PatBindIn4 12 30 fails" $ do + res <- catchException (ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/PatBindIn4.hs" (12,30)) + -- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/PatBindIn4.hs" (12,30) + + (show res) `shouldBe` "Just \"Cannot lift a declaration assigning to a tuple pattern\"" + + -- --------------------------------- it "liftToTopLevel CaseIn1 10 28" $ do - r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/CaseIn1.hs" (10,28) - -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/CaseIn1.hs" (10,28) + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/CaseIn1.hs" (10,28) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/CaseIn1.hs" (10,28) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/CaseIn1.hs\"]" diff <- compareFiles "./test/testdata/LiftToToplevel/CaseIn1.hs.expected" @@ -213,30 +233,18 @@ -- --------------------------------- - it "liftToTopLevel PatBindIn2 17 7 fails" $ do -{- - res <- catchException (doLiftToTopLevel ["./test/testdata/LiftToToplevel/PatBindIn2.hs","17","7"]) - -- liftToTopLevel logTestSettings Nothing "./test/testdata/LiftToToplevel/PatBindIn2.hs" (17,7) - - (show res) `shouldBe` "Just \"\\nThe identifier is not a local function/pattern name!\"" --} - pending -- Not clear that this was covered in the original, will - -- come back to it - - -- --------------------------------- - it "liftToTopLevel WhereIn2 11 18 fails" $ do -- res <- catchException (doLiftToTopLevel ["./test/testdata/LiftToToplevel/WhereIn2.hs","11","18"]) - res <- catchException (liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/WhereIn2.hs" (11,18)) + res <- catchException (ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/WhereIn2.hs" (11,18)) -- liftToTopLevel logTestSettings testOptions Nothing "./test/testdata/LiftToToplevel/WhereIn2.hs" (11,18) - (show res) `shouldBe` "Just \"The identifier(s): (sq, test/testdata/LiftToToplevel/WhereIn2.hs:11:18) will cause name clash/capture or ambiguity occurrence problem after lifting, please do renaming first!\"" + (show res) `shouldBe` "Just \"The identifier(s): (sq, LiftToToplevel/WhereIn2.hs:11:18) will cause name clash/capture or ambiguity occurrence problem after lifting, please do renaming first!\"" -- --------------------------------- it "liftToTopLevel Collapse1 8 6" $ do - r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Collapse1.hs" (8,6) - -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/Collapse1.hs" (8,6) + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/Collapse1.hs" (8,6) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/Collapse1.hs" (8,6) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/Collapse1.hs\"]" diff <- compareFiles "./test/testdata/LiftToToplevel/Collapse1.expected.hs" @@ -266,8 +274,8 @@ -- --------------------------------- it "liftToTopLevel Zmapq" $ do - r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Zmapq.hs" (6,3) - -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/Zmapq.hs" (6,3) + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/Zmapq.hs" (6,3) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/Zmapq.hs" (6,3) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/Zmapq.hs\"]" diff <- compareFiles "./test/testdata/LiftToToplevel/Zmapq.expected.hs" @@ -277,8 +285,8 @@ -- --------------------------------- it "liftToTopLevel LiftInLambda 10 5" $ do - r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/LiftInLambda.hs" (10,5) - -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/LiftInLambda.hs" (10,5) + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/LiftInLambda.hs" (10,5) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/LiftInLambda.hs" (10,5) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/LiftInLambda.hs\"]" diff <- compareFiles "./test/testdata/LiftToToplevel/LiftInLambda.expected.hs" @@ -288,8 +296,8 @@ -- --------------------------------- it "liftToTopLevel NoWhere" $ do - r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/NoWhere.hs" (14,12) - -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/NoWhere.hs" (14,12) + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/NoWhere.hs" (14,12) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/NoWhere.hs" (14,12) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/NoWhere.hs\"]" diff <- compareFiles "./test/testdata/LiftToToplevel/NoWhere.expected.hs" @@ -299,8 +307,8 @@ -- --------------------------------- it "liftToTopLevel Signature" $ do - r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Signature.hs" (9,5) - -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/Signature.hs" (9,5) + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/Signature.hs" (9,5) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/Signature.hs" (9,5) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/Signature.hs\"]" diff <- compareFiles "./test/testdata/LiftToToplevel/Signature.expected.hs" @@ -312,13 +320,13 @@ it "liftToTopLevel Signature2" $ do -- should throw exception for forall in signature - res <- catchException (liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Signature2.hs" (16,5)) - -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/Signature2.hs" (16,5) + res <- catchException (ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/Signature2.hs" (16,5)) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/Signature2.hs" (16,5) (show res) `shouldBe` "Just \"\\nNew type signature may fail type checking: :: (forall t. Num t => t -> t -> t) -> Int -> \\n\"" {- - r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Signature2.hs" (16,5) - -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/Signature2.hs" (16,5) + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/Signature2.hs" (16,5) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/Signature2.hs" (16,5) (show r) `shouldBe` "[\"./test/testdata/LiftToToplevel/Signature2.hs\"]" diff <- compareFiles "./test/testdata/LiftToToplevel/Signature2.expected.hs" "./test/testdata/LiftToToplevel/Signature2.refactored.hs" @@ -330,9 +338,9 @@ it "liftToTopLevel Signature2r" $ do -- should throw exception for forall in signature - r <- catchException (liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Signature2r.hs" (12,5)) - -- r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Signature2r.hs" (12,5) - -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/Signature2r.hs" (12,5) + r <- catchException (ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/Signature2r.hs" (12,5)) + -- r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/Signature2r.hs" (12,5) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/Signature2r.hs" (12,5) (show r) `shouldBe` "Just \"\\nNew type signature may fail type checking: :: (forall t. Num t => t -> t -> t) -> Int -> \\n\"" {- (show r) `shouldBe` "[\"./test/testdata/LiftToToplevel/Signature2r.hs\"]" @@ -344,8 +352,8 @@ -- --------------------------------- it "liftToTopLevel Signature3" $ do - r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Signature3.hs" (9,5) - -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/Signature3.hs" (9,5) + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/Signature3.hs" (9,5) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/Signature3.hs" (9,5) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/Signature3.hs\"]" diff <- compareFiles "./test/testdata/LiftToToplevel/Signature3.expected.hs" @@ -356,9 +364,9 @@ it "liftToTopLevel Signature4" $ do -- should throw exception for forall in signature - r <- catchException $ liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Signature4.hs" (9,5) - -- r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Signature4.hs" (9,5) - -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/Signature4.hs" (9,5) + r <- catchException $ ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/Signature4.hs" (9,5) + -- r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/Signature4.hs" (9,5) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/Signature4.hs" (9,5) (show r) `shouldBe` "Just \"\\nNew type signature may fail type checking: :: (forall t. (Integral t, Num t) => t -> t -> Int) -> t -> \\n\"" {- (show r) `shouldBe` "[\"./test/testdata/LiftToToplevel/Signature4.hs\"]" @@ -423,8 +431,8 @@ -- --------------------------------- it "LiftOneLevel WhereIn1 12 18" $ do - r <- liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn1.hs" (12,18) - -- r <- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn1.hs" (12,18) + r <- ct $ liftOneLevel defaultTestSettings testOptions "./LiftOneLevel/WhereIn1.hs" (12,18) + -- r <- ct $ liftOneLevel logTestSettings testOptions "./LiftOneLevel/WhereIn1.hs" (12,18) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftOneLevel/WhereIn1.hs\"]" diff <- compareFiles "./test/testdata/LiftOneLevel/WhereIn1.hs.expected" @@ -434,8 +442,8 @@ -- --------------------------------- it "LiftOneLevel WhereIn6 13 29" $ do - r <- liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn6.hs" (13,29) - -- r <- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn6.hs" (13,29) + r <- ct $ liftOneLevel defaultTestSettings testOptions "./LiftOneLevel/WhereIn6.hs" (13,29) + -- r <- ct $ liftOneLevel logTestSettings testOptions "./LiftOneLevel/WhereIn6.hs" (13,29) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftOneLevel/WhereIn6.hs\"]" diff <- compareFiles "./test/testdata/LiftOneLevel/WhereIn6.hs.expected" @@ -446,8 +454,8 @@ -- --------------------------------- it "liftOneLevel WhereIn7 12 14" $ do - r <- liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn7.hs" (12,14) - -- r <- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn7.hs" (12,14) + r <- ct $ liftOneLevel defaultTestSettings testOptions "./LiftOneLevel/WhereIn7.hs" (12,14) + -- r <- ct $ liftOneLevel logTestSettings testOptions "./LiftOneLevel/WhereIn7.hs" (12,14) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftOneLevel/WhereIn7.hs\"]" diff <- compareFiles "./test/testdata/LiftOneLevel/WhereIn7.hs.expected" @@ -457,8 +465,8 @@ -- --------------------------------- it "LiftOneLevel WhereIn8 8 11" $ do - r <- liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn8.hs" (8,11) - -- r <- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn8.hs" (8,11) + r <- ct $ liftOneLevel defaultTestSettings testOptions "./LiftOneLevel/WhereIn8.hs" (8,11) + -- r <- ct $ liftOneLevel logTestSettings testOptions "./LiftOneLevel/WhereIn8.hs" (8,11) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftOneLevel/WhereIn8.hs\"]" diff <- compareFiles "./test/testdata/LiftOneLevel/WhereIn8.hs.expected" @@ -468,8 +476,8 @@ -- --------------------------------- it "LiftOneLevel LetIn1 11 22" $ do - r <- liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/LetIn1.hs" (11,22) - -- r <- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/LetIn1.hs" (11,22) + r <- ct $ liftOneLevel defaultTestSettings testOptions "./LiftOneLevel/LetIn1.hs" (11,22) + -- r <- ct $ liftOneLevel logTestSettings testOptions "./LiftOneLevel/LetIn1.hs" (11,22) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftOneLevel/LetIn1.hs\"]" diff <- compareFiles "./test/testdata/LiftOneLevel/LetIn1.hs.expected" @@ -480,8 +488,8 @@ -- --------------------------------- it "LiftOneLevel LetIn2 11 22" $ do - r <- liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/LetIn2.hs" (11,22) - -- r <- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/LetIn2.hs" (11,22) + r <- ct $ liftOneLevel defaultTestSettings testOptions "./LiftOneLevel/LetIn2.hs" (11,22) + -- r <- ct $ liftOneLevel logTestSettings testOptions "./LiftOneLevel/LetIn2.hs" (11,22) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftOneLevel/LetIn2.hs\"]" diff <- compareFiles "./test/testdata/LiftOneLevel/LetIn2.hs.expected" @@ -491,8 +499,8 @@ -- --------------------------------- it "LiftOneLevel LetIn3 10 27" $ do - r <- liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/LetIn3.hs" (10,27) - -- r <- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/LetIn3.hs" (10,27) + r <- ct $ liftOneLevel defaultTestSettings testOptions "./LiftOneLevel/LetIn3.hs" (10,27) + -- r <- ct $ liftOneLevel logTestSettings testOptions "./LiftOneLevel/LetIn3.hs" (10,27) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftOneLevel/LetIn3.hs\"]" diff <- compareFiles "./test/testdata/LiftOneLevel/LetIn3.hs.expected" @@ -502,8 +510,8 @@ -- --------------------------------- it "LiftOneLevel PatBindIn3 11 15" $ do - r <- liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/PatBindIn3.hs" (11,15) - -- r <- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/PatBindIn3.hs" (11,15) + r <- ct $ liftOneLevel defaultTestSettings testOptions "./LiftOneLevel/PatBindIn3.hs" (11,15) + -- r <- ct $ liftOneLevel logTestSettings testOptions "./LiftOneLevel/PatBindIn3.hs" (11,15) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftOneLevel/PatBindIn3.hs\"]" diff <- compareFiles "./test/testdata/LiftOneLevel/PatBindIn3.hs.expected" @@ -513,8 +521,8 @@ -- --------------------------------- it "liftOneLevel CaseIn1 10 28" $ do - r <- liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/CaseIn1.hs" (10,28) - -- r <- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/CaseIn1.hs" (10,28) + r <- ct $ liftOneLevel defaultTestSettings testOptions "./LiftOneLevel/CaseIn1.hs" (10,28) + -- r <- ct $ liftOneLevel logTestSettings testOptions "./LiftOneLevel/CaseIn1.hs" (10,28) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/LiftOneLevel/CaseIn1.hs\"]" diff <- compareFiles "./test/testdata/LiftOneLevel/CaseIn1.hs.expected" @@ -535,9 +543,9 @@ -- ----------------------------------------------------------------- it "fails WhereIn2 8 18" $ do - res <- catchException (liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn2.hs" (8,18)) - -- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn2.hs" (8,18) - (show res) `shouldBe` "Just \"The identifier(s): (sq, test/testdata/LiftOneLevel/WhereIn2.hs:8:18) will cause name clash/capture or ambiguity occurrence problem after lifting, please do renaming first!\"" + res <- catchException (ct $ liftOneLevel defaultTestSettings testOptions "./LiftOneLevel/WhereIn2.hs" (8,18)) + -- liftOneLevel logTestSettings testOptions "./LiftOneLevel/WhereIn2.hs" (8,18) + (show res) `shouldBe` "Just \"The identifier(s): (sq, LiftOneLevel/WhereIn2.hs:8:18) will cause name clash/capture or ambiguity occurrence problem after lifting, please do renaming first!\"" -- TODO: check that other declarations in a list that make use of the @@ -569,19 +577,19 @@ it "notifies if no definition selected" $ do -- res <- catchException (doDemote ["./test/testdata/MoveDef/Md1.hs","14","13"]) - res <- catchException (demote defaultTestSettings testOptions "./test/testdata/MoveDef/Md1.hs" (14,13)) + res <- catchException (ct $ demote defaultTestSettings testOptions "./MoveDef/Md1.hs" (14,13)) (show res) `shouldBe` "Just \"\\nInvalid cursor position!\"" it "will not demote if nowhere to go" $ do - res <- catchException (demote defaultTestSettings testOptions "./test/testdata/MoveDef/Md1.hs" (8,1)) - -- res <- demote logTestSettings testOptions "./test/testdata/MoveDef/Md1.hs" (8,1) + res <- catchException (ct $ demote defaultTestSettings testOptions "./MoveDef/Md1.hs" (8,1)) + -- res <- ct $ demote logTestSettings testOptions "./MoveDef/Md1.hs" (8,1) (show res) `shouldBe` "Just \"\\n Nowhere to demote this function!\\n\"" -- ----------------------------------------------------------------- it "demotes a definition from the top level 1" $ do - r <- demote defaultTestSettings testOptions "./test/testdata/MoveDef/Demote.hs" (7,1) - -- r <- demote logTestSettings testOptions "./test/testdata/MoveDef/Demote.hs" (7,1) + r <- ct $ demote defaultTestSettings testOptions "./MoveDef/Demote.hs" (7,1) + -- r <- ct $ demote logTestSettings testOptions "./MoveDef/Demote.hs" (7,1) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/MoveDef/Demote.hs\"]" diff <- compareFiles "./test/testdata/MoveDef/Demote.refactored.hs" @@ -591,8 +599,8 @@ -- ----------------------------------------------------------------- it "demotes a definition from the top level D1" $ do - r <- demote defaultTestSettings testOptions "./test/testdata/Demote/D1.hs" (9,1) - -- r <- demote logTestSettings testOptions "./test/testdata/Demote/D1.hs" (9,1) + r <- ct $ demote defaultTestSettings testOptions "./Demote/D1.hs" (9,1) + -- r <- ct $ demote logTestSettings testOptions "./Demote/D1.hs" (9,1) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/Demote/D1.hs\"]" diff <- compareFiles "./test/testdata/Demote/D1.refactored.hs" @@ -602,7 +610,7 @@ -- ----------------------------------------------------------------- it "demotes WhereIn1 12 1" $ do - r <- demote defaultTestSettings testOptions "./test/testdata/Demote/WhereIn1.hs" (12,1) + r <- ct $ demote defaultTestSettings testOptions "./Demote/WhereIn1.hs" (12,1) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/Demote/WhereIn1.hs\"]" diff <- compareFiles "./test/testdata/Demote/WhereIn1.refactored.hs" @@ -612,8 +620,8 @@ -- ----------------------------------------------------------------- it "demotes WhereIn3 14 1" $ do - r <- demote defaultTestSettings testOptions "./test/testdata/Demote/WhereIn3.hs" (14,1) - -- r <- demote logTestSettings testOptions "./test/testdata/Demote/WhereIn3.hs" (14,1) + r <- ct $ demote defaultTestSettings testOptions "./Demote/WhereIn3.hs" (14,1) + -- r <- ct $ demote logTestSettings testOptions "./Demote/WhereIn3.hs" (14,1) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/Demote/WhereIn3.hs\"]" diff <- compareFiles "./test/testdata/Demote/WhereIn3.refactored.hs" @@ -624,7 +632,7 @@ it "demotes WhereIn4 14 1" $ do -- r <- doDemote ["./test/testdata/Demote/WhereIn4.hs","14","1"] - r <- demote defaultTestSettings testOptions "./test/testdata/Demote/WhereIn4.hs" (14,1) + r <- ct $ demote defaultTestSettings testOptions "./Demote/WhereIn4.hs" (14,1) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/Demote/WhereIn4.hs\"]" diff <- compareFiles "./test/testdata/Demote/WhereIn4.refactored.hs" @@ -634,8 +642,8 @@ -- ----------------------------------------------------------------- it "demotes WhereIn5 14 1" $ do - r <- demote defaultTestSettings testOptions "./test/testdata/Demote/WhereIn5.hs" (14,1) - -- r <- demote logTestSettings testOptions "./test/testdata/Demote/WhereIn5.hs" (14,1) + r <- ct $ demote defaultTestSettings testOptions "./Demote/WhereIn5.hs" (14,1) + -- r <- ct $ demote logTestSettings testOptions "./Demote/WhereIn5.hs" (14,1) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/Demote/WhereIn5.hs\"]" diff <- compareFiles "./test/testdata/Demote/WhereIn5.refactored.hs" @@ -645,8 +653,8 @@ -- ----------------------------------------------------------------- it "demotes WhereIn6 13 1" $ do - r <- demote defaultTestSettings testOptions "./test/testdata/Demote/WhereIn6.hs" (13,1) - -- r <- demote logTestSettings testOptions "./test/testdata/Demote/WhereIn6.hs" (13,1) + r <- ct $ demote defaultTestSettings testOptions "./Demote/WhereIn6.hs" (13,1) + -- r <- ct $ demote logTestSettings testOptions "./Demote/WhereIn6.hs" (13,1) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/Demote/WhereIn6.hs\"]" diff <- compareFiles "./test/testdata/Demote/WhereIn6.refactored.hs" @@ -656,8 +664,8 @@ -- ----------------------------------------------------------------- it "demotes WhereIn7 13 1" $ do - r <- demote defaultTestSettings testOptions "./test/testdata/Demote/WhereIn7.hs" (13,1) - -- r <- demote logTestSettings testOptions "./test/testdata/Demote/WhereIn7.hs" (13,1) + r <- ct $ demote defaultTestSettings testOptions "./Demote/WhereIn7.hs" (13,1) + -- r <- ct $ demote logTestSettings testOptions "./Demote/WhereIn7.hs" (13,1) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/Demote/WhereIn7.hs\"]" diff <- compareFiles "./test/testdata/Demote/WhereIn7.refactored.hs" @@ -667,8 +675,8 @@ -- ----------------------------------------------------------------- it "demotes CaseIn1 16 1" $ do - r <- demote defaultTestSettings testOptions "./test/testdata/Demote/CaseIn1.hs" (16,1) - -- r <- demote logTestSettings testOptions "./test/testdata/Demote/CaseIn1.hs" (16,1) + r <- ct $ demote defaultTestSettings testOptions "./Demote/CaseIn1.hs" (16,1) + -- r <- ct $ demote logTestSettings testOptions "./Demote/CaseIn1.hs" (16,1) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/Demote/CaseIn1.hs\"]" diff <- compareFiles "./test/testdata/Demote/CaseIn1.refactored.hs" @@ -678,8 +686,8 @@ -- ----------------------------------------------------------------- it "demotes LetIn1 12 22" $ do - r <- demote defaultTestSettings testOptions "./test/testdata/Demote/LetIn1.hs" (12,22) - -- r <- demote logTestSettings testOptions "./test/testdata/Demote/LetIn1.hs" (12,22) + r <- ct $ demote defaultTestSettings testOptions "./Demote/LetIn1.hs" (12,22) + -- r <- ct $ demote logTestSettings testOptions "./Demote/LetIn1.hs" (12,22) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/Demote/LetIn1.hs\"]" diff <- compareFiles "./test/testdata/Demote/LetIn1.refactored.hs" @@ -689,7 +697,7 @@ -- ----------------------------------------------------------------- it "demotes PatBindIn1 19 1" $ do - r <- demote defaultTestSettings testOptions "./test/testdata/Demote/PatBindIn1.hs" (19,1) + r <- ct $ demote defaultTestSettings testOptions "./Demote/PatBindIn1.hs" (19,1) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/Demote/PatBindIn1.hs\"]" diff <- compareFiles "./test/testdata/Demote/PatBindIn1.refactored.hs" @@ -698,20 +706,20 @@ -- ----------------------------------------------------------------- - it "demotes D2 5 1 when not imported by other module" $ do - r <- demote defaultTestSettings testOptions "./test/testdata/Demote/D2.hs" (5,1) - -- r <- demote logTestSettings testOptions "./test/testdata/Demote/D2.hs" (5,1) + it "demotes D2a 5 1 when not imported by other module" $ do + r <- ct $ demote defaultTestSettings testOptions "./Demote/D2a.hs" (5,1) + -- r <- ct $ demote logTestSettings testOptions "./Demote/D2a.hs" (5,1) r' <- mapM makeRelativeToCurrentDirectory r - (show r') `shouldBe` "[\"test/testdata/Demote/D2.hs\"]" - diff <- compareFiles "./test/testdata/Demote/D2.refactored.hs" - "./test/testdata/Demote/D2.hs.expected" + (show r') `shouldBe` "[\"test/testdata/Demote/D2a.hs\"]" + diff <- compareFiles "./test/testdata/Demote/D2a.refactored.hs" + "./test/testdata/Demote/D2a.hs.expected" diff `shouldBe` [] -- ----------------------------------------------------------------- it "fails WhereIn2 14 1" $ do -- res <- catchException (doDemote ["./test/testdata/Demote/WhereIn2.hs","14","1"]) - res <- catchException (demote defaultTestSettings testOptions "./test/testdata/Demote/WhereIn2.hs" (14,1)) + res <- catchException (ct $ demote defaultTestSettings testOptions "./Demote/WhereIn2.hs" (14,1)) -- demote (Just logSettings) testOptions Nothing "./test/testdata/Demote/WhereIn2.hs" (14,1) (show res) `shouldBe` "Just \"\\n Nowhere to demote this function!\\n\"" @@ -719,14 +727,14 @@ it "fails LetIn2 11 22" $ do -- res <- catchException (doDemote ["./test/testdata/Demote/LetIn2.hs","11","22"]) - res <- catchException (demote defaultTestSettings testOptions "./test/testdata/Demote/LetIn2.hs" (11,22)) + res <- catchException (ct $ demote defaultTestSettings testOptions "./Demote/LetIn2.hs" (11,22)) (show res) `shouldBe` "Just \"This function can not be demoted as it is used in current level!\\n\"" -- ----------------------------------------------------------------- it "fails PatBindIn4 18 1" $ do -- res <- catchException (doDemote ["./test/testdata/Demote/PatBindIn4.hs","18","1"]) - res <- catchException (demote defaultTestSettings testOptions "./test/testdata/Demote/PatBindIn4.hs" (18,1)) + res <- catchException (ct $ demote defaultTestSettings testOptions "./Demote/PatBindIn4.hs" (18,1)) -- (show res) `shouldBe` "Just \"\\n Nowhere to demote this function!\\n\"" (show res) `shouldBe` "Just \"\\nThis function/pattern binding is used by more than one friend bindings\\n\"" @@ -734,7 +742,7 @@ it "fails WhereIn8 16 1" $ do -- res <- catchException (doDemote ["./test/testdata/Demote/WhereIn8.hs","16","1"]) - res <- catchException (demote defaultTestSettings testOptions "./test/testdata/Demote/WhereIn8.hs" (16,1)) + res <- catchException (ct $ demote defaultTestSettings testOptions "./Demote/WhereIn8.hs" (16,1)) (show res) `shouldBe` "Just \"\\n Nowhere to demote this function!\\n\"" -- ----------------------------------------------------------------- @@ -753,7 +761,7 @@ it "fails D3 5 1" $ do -- res <- catchException (doDemote ["./test/testdata/Demote/D3.hs","5","1"]) - res <- catchException (demote defaultTestSettings testOptions "./test/testdata/Demote/D3.hs" (5,1)) + res <- catchException (ct $ demote defaultTestSettings testOptions "./Demote/D3.hs" (5,1)) (show res) `shouldBe` "Just \"This definition can not be demoted, as it is explicitly exported by the current module!\"" @@ -783,16 +791,16 @@ -- ----------------------------------------------------------------- it "fails MultiLeg.hs" $ do - res <- catchException (demote defaultTestSettings testOptions "./test/testdata/Demote/MultiLeg.hs" (14,1)) - -- demote logTestSettings testOptions "./test/testdata/Demote/MultiLeg.hs" (14,1) + res <- catchException (ct $ demote defaultTestSettings testOptions "./Demote/MultiLeg.hs" (14,1)) + -- demote logTestSettings testOptions "./Demote/MultiLeg.hs" (14,1) (show res) `shouldBe` "Just \"\\nThis function/pattern binding is used by more than one friend bindings\\n\"" -- ----------------------------------------------------------------- it "passes MultiLeg2.hs" $ do - r <- demote defaultTestSettings testOptions "./test/testdata/Demote/MultiLeg2.hs" (14,1) - -- demote logTestSettings testOptions "./test/testdata/Demote/MultiLeg2.hs" (14,1) + r <- ct $ demote defaultTestSettings testOptions "./Demote/MultiLeg2.hs" (14,1) + -- demote logTestSettings testOptions "./Demote/MultiLeg2.hs" (14,1) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/Demote/MultiLeg2.hs\"]" @@ -804,8 +812,8 @@ -- ----------------------------------------------------------------- it "passes UsedAtLevel.hs" $ do - r <- demote defaultTestSettings testOptions "./test/testdata/Demote/UsedAtLevel.hs" (19,12) - -- demote logTestSettings testOptions "./test/testdata/Demote/UsedAtLevel.hs" (19,12) + r <- ct $ demote defaultTestSettings testOptions "./Demote/UsedAtLevel.hs" (19,12) + -- demote logTestSettings testOptions "./Demote/UsedAtLevel.hs" (19,12) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/Demote/UsedAtLevel.hs\"]" @@ -816,8 +824,8 @@ -- ----------------------------------------------------------------- it "passes UsedAtLevel.hs2" $ do - r <- demote defaultTestSettings testOptions "./test/testdata/Demote/UsedAtLevel2.hs" (23,12) - -- demote logTestSettings testOptions "./test/testdata/Demote/UsedAtLevel2.hs" (23,12) + r <- ct $ demote defaultTestSettings testOptions "./Demote/UsedAtLevel2.hs" (23,12) + -- demote logTestSettings testOptions "./Demote/UsedAtLevel2.hs" (23,12) r' <- mapM makeRelativeToCurrentDirectory r (show r') `shouldBe` "[\"test/testdata/Demote/UsedAtLevel2.hs\"]" diff --git a/test/RenamingSpec.hs b/test/RenamingSpec.hs --- a/test/RenamingSpec.hs +++ b/test/RenamingSpec.hs @@ -207,7 +207,7 @@ it "renames in Field4 5 23" $ do r <- ct $ rename defaultTestSettings testOptions "./Renaming/Field4.hs" "value2" (5,23) - -- ct $ rename logTestSettings Nothing "./Renaming/Field4.hs" "value2" (5,23) + -- ct $ rename logTestSettings testOptions "./Renaming/Field4.hs" "value2" (5,23) r' <- ct $ mapM makeRelativeToCurrentDirectory r r' `shouldBe` [ "Renaming/Field4.hs" ] @@ -301,6 +301,18 @@ -- --------------------------------- + it "renames in Constructor 5 16" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/Constructor.hs" "MyType" (5,16) + -- ct $ rename logTestSettings testOptions "./Renaming/Constructor.hs" "MyType" (5,16) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` [ "Renaming/Constructor.hs" + ] + diff <- ct $ compareFiles "./Renaming/Constructor.expected.hs" + "./Renaming/Constructor.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + it "renames in LayoutIn1 7 17" $ do r <- ct $ rename defaultTestSettings testOptions "./Renaming/LayoutIn1.hs" "square" (7,17) -- ct $ rename logTestSettings testOptions "./Renaming/LayoutIn1.hs" "square" (7,17) @@ -315,7 +327,7 @@ it "renames in LayoutIn2 8 7" $ do r <- ct $ rename defaultTestSettings testOptions "./Renaming/LayoutIn2.hs" "ls" (8,7) - -- ct $ rename logTestSettings testOptions Nothing "./Renaming/LayoutIn2.hs" "ls" (8,7) + -- ct $ rename logTestSettings testOptions "./Renaming/LayoutIn2.hs" "ls" (8,7) r' <- ct $ mapM makeRelativeToCurrentDirectory r r' `shouldBe` [ "Renaming/LayoutIn2.hs" ] @@ -366,8 +378,8 @@ -- --------------------------------- it "naming clash IdIn5" $ do - -- ct $ rename logTestSettings testOptions "./Renaming/IdIn5.hs" "y" (10,1) - res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/IdIn5.hs" "y" (10,1)) + -- ct $ rename logTestSettings testOptions "./Renaming/IdIn5.hs" "y" (13,1) + res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/IdIn5.hs" "y" (13,1)) (show res) `shouldBe` "Just \"Name 'y' already exists, or renaming 'IdIn5.x' to 'y' will change the program's semantics!\\n\"" -- --------------------------------- @@ -394,7 +406,7 @@ -- --------------------------------- it "cannot rename main Main" $ do - -- rename logTestSettings testOptions Nothing "./Renaming/Main.hs" "main1" (11,1) + -- rename logTestSettings testOptions "./Renaming/Main.hs" "main1" (11,1) res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/Main.hs" "main1" (11,1)) (show res) `shouldBe` "Just \"The 'main' function defined in a 'Main' module should not be renamed!\"" @@ -407,8 +419,36 @@ -- --------------------------------- + it "cannot rename x InScopes 1" $ do + -- res <- catchException (ct $ rename logTestSettings testOptions "./Renaming/InScopes.hs" "g" (6,22)) + res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/InScopes.hs" "g" (6,22)) + show res `shouldBe` "Just \"The new name will cause name capture!\"" + + -- --------------------------------- + + it "cannot rename x InScopes 2" $ do + -- res <- catchException (ct $ rename logTestSettings testOptions "./Renaming/InScopes.hs" "g" (10,10)) + res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/InScopes.hs" "g" (10,10)) + show res `shouldBe` "Just \"The new name will cause name capture!\"" + + -- --------------------------------- + + it "cannot rename x InScopes 3" $ do + -- res <- catchException (ct $ rename logTestSettings testOptions "./Renaming/InScopes.hs" "g" (12,8)) + res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/InScopes.hs" "g" (12,8)) + show res `shouldBe` "Just \"The new name will cause name capture!\"" + + -- --------------------------------- + + it "cannot rename x InScopes 4" $ do + -- res <- catchException (ct $ rename logTestSettings testOptions "./Renaming/InScopes.hs" "g" (21,12)) + res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/InScopes.hs" "g" (21,12)) + show res `shouldBe` "Just \"The new name will cause name capture!\"" + + -- --------------------------------- + it "rename with default main Main2" $ do - -- ct $ rename logTestSettings testOptions Nothing "./Renaming/Main2.hs" "baz" (6,1) + -- ct $ rename logTestSettings testOptions "./Renaming/Main2.hs" "baz" (6,1) r <- ct $ rename defaultTestSettings testOptions "./Renaming/Main2.hs" "baz" (6,1) r' <- ct $ mapM makeRelativeToCurrentDirectory r @@ -584,6 +624,48 @@ (show r') `shouldBe` "[\"Renaming/RenameInExportedType2.hs\"]" diff <- ct $ compareFiles "./Renaming/RenameInExportedType2.refactored.hs" "./Renaming/RenameInExportedType2.expected.hs" + diff `shouldBe` [] + + -- ----------------------------------------------------------------- + + it "passes ExportedType.hs for type name" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/ExportedType.hs" "NewType" (4,7) + -- ct $ rename logTestSettings testOptions "./Renaming/ExportedType.hs" "NewType" (4,7) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"Renaming/ExportedType.hs\",\"Renaming/ExportedTypeClient.hs\"]" + diff <- ct $ compareFiles "./Renaming/ExportedType.refactored.hs" + "./Renaming/ExportedType.expected.hs" + diff `shouldBe` [] + diff2 <- ct $ compareFiles "./Renaming/ExportedTypeClient.refactored.hs" + "./Renaming/ExportedTypeClient.expected.hs" + diff2 `shouldBe` [] + + -- ----------------------------------------------------------------- + + it "passes ExportedType.hs for type constructor" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/ExportedType.hs" "NewType" (4,16) + -- ct $ rename logTestSettings testOptions "./Renaming/ExportedType.hs" "NewType" (4,16) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"Renaming/ExportedType.hs\",\"Renaming/ExportedTypeClient.hs\"]" + diff <- ct $ compareFiles "./Renaming/ExportedType.refactored.hs" + "./Renaming/ExportedType.expected2.hs" + diff `shouldBe` [] + diff2 <- ct $ compareFiles "./Renaming/ExportedTypeClient.refactored.hs" + "./Renaming/ExportedTypeClient.expected2.hs" + diff2 `shouldBe` [] + + -- ----------------------------------------------------------------- + + it "passes WildCard.hs" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/WildCard.hs" "taggedPlugins2" (7,1) + -- r <- ct $ rename logTestSettings testOptions "./Renaming/WildCard.hs" "taggedPlugins2" (7,1) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"Renaming/WildCard.hs\"]" + diff <- ct $ compareFiles "./Renaming/WildCard.refactored.hs" + "./Renaming/WildCard.expected.hs" diff `shouldBe` [] -- ----------------------------------------------------------------- diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} -{- - -See https://github.com/hspec/hspec/tree/master/hspec-discover#readme -to understand this module - --} diff --git a/test/SwapArgsSpec.hs b/test/SwapArgsSpec.hs --- a/test/SwapArgsSpec.hs +++ b/test/SwapArgsSpec.hs @@ -25,7 +25,7 @@ describe "swapArgs" $ do it "checks for that an identifier is selected" $ do - res <- catchException (swapArgs defaultTestSettings testOptions ["./test/testdata/SwapArgs/B.hs","4","1"]) + res <- catchException (ct $ swapArgs defaultTestSettings testOptions ["./SwapArgs/B.hs","4","1"]) -- let res = "foo" (show res) `shouldBe` "Just \"Incorrect identifier selected!\"" diff --git a/test/TestUtils.hs b/test/TestUtils.hs --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -255,7 +255,7 @@ Just tm -> r where anns = tkCache (rsTokenCache tm) Map.! mainTid - parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module + parsed = GHC.pm_parsed_source $ tmParsedModule $ rsTypecheckedMod tm r = showAnnData anns 0 parsed Nothing -> [] @@ -304,7 +304,7 @@ Just tm -> r where anns = tkCache (rsTokenCache tm) Map.! mainTid - parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module + parsed = GHC.pm_parsed_source $ tmParsedModule $ rsTypecheckedMod tm r = exactPrint parsed anns Nothing -> [] diff --git a/test/TypeUtilsSpec.hs b/test/TypeUtilsSpec.hs --- a/test/TypeUtilsSpec.hs +++ b/test/TypeUtilsSpec.hs @@ -18,12 +18,14 @@ import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.Refact.Utils.GhcVersionSpecific import Language.Haskell.Refact.Utils.LocUtils import Language.Haskell.Refact.Utils.Monad import Language.Haskell.Refact.Utils.MonadFunctions import Language.Haskell.Refact.Utils.TypeUtils +import Language.Haskell.Refact.Utils.Types import Language.Haskell.Refact.Utils.Utils import Language.Haskell.Refact.Utils.Variables @@ -41,8 +43,8 @@ describe "findAllNameOccurences" $ do it "finds all occurrences of the given name in a syntax phrase" $ do t <- ct $ parsedFileGhc "./TypeUtils/S.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (4,5) parsed @@ -58,7 +60,7 @@ describe "locToName" $ do it "returns a GHC.Name for a given source location, if it falls anywhere in an identifier #1" $ do t <- ct $ parsedFileGhc "./TypeUtils/B.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just (res'@(GHC.L l _)) = locToRdrName (7,3) parsed @@ -72,7 +74,7 @@ it "returns a GHC.Name for a given source location, if it falls anywhere in an identifier #2" $ do t <- ct $ parsedFileGhc "./TypeUtils/B.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just (res'@(GHC.L l _)) = locToRdrName (25,8) parsed @@ -86,7 +88,7 @@ it "returns Nothing for a given source location, if it does not fall in an identifier" $ do t <- ct $ parsedFileGhc "TypeUtils/B.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let res = locToNameRdrPure nm (7,7) parsed @@ -96,7 +98,7 @@ it "gets a short name too" $ do t <- ct $ parsedFileGhc "./Demote/WhereIn2.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just (res'@(GHC.L l _)) = locToRdrName (14,1) parsed @@ -110,7 +112,7 @@ it "gets a type variable name" $ do t <- ct $ parsedFileGhc "./Renaming/ConstructorIn3.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just (res'@(GHC.L l _)) = locToRdrName (9,12) parsed @@ -125,7 +127,7 @@ it "gets an instance class name" $ do t <- ct $ parsedFileGhc "./Renaming/ClassIn3.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just (res'@(GHC.L l _)) = locToRdrName (16,10) parsed n = rdrName2NamePure nm res' @@ -139,7 +141,7 @@ describe "locToRdrName" $ do it "returns a GHC.RdrName for a given source location, if it falls anywhere in an identifier" $ do t <- ct $ parsedFileGhc "./Renaming/D5.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let Just (res@(GHC.L l n)) = locToRdrName (20,1) parsed (show $ ss2span l) `shouldBe` "((20,1),(20,11))" @@ -148,7 +150,7 @@ it "returns a GHC.RdrName for a source location, in a MatchGroup" $ do t <- ct $ parsedFileGhc "./LocToName.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let Just (res@(GHC.L l n)) = locToRdrName (24,2) parsed showGhcQual n `shouldBe` "sumSquares" @@ -160,21 +162,21 @@ describe "getName" $ do it "gets a qualified Name at the top level" $ do t <- ct $ parsedFileGhc "./TypeUtils/B.hs" - let renamed = fromJust $ GHC.tm_renamed_source t + let renamed = tmRenamedSource t let Just n = getName "TypeUtils.B.foo'" renamed (showGhcQual n) `shouldBe` "TypeUtils.B.foo'" (showGhcQual $ GHC.getSrcSpan n) `shouldBe` "TypeUtils/B.hs:14:1-4" it "gets any instance of an unqualified Name" $ do t <- ct $ parsedFileGhc "./TypeUtils/B.hs" - let renamed = fromJust $ GHC.tm_renamed_source t + let renamed = tmRenamedSource t let Just n = getName "foo" renamed (showGhcQual n) `shouldBe` "foo" (showGhcQual $ GHC.getSrcSpan n) `shouldBe` "TypeUtils/B.hs:9:15-17" it "returns Nothing if the Name is not found" $ do t <- ct $ parsedFileGhc "./TypeUtils/B.hs" - let renamed = fromJust $ GHC.tm_renamed_source t + let renamed = tmRenamedSource t let res = getName "baz" renamed (showGhcQual res) `shouldBe` "Nothing" @@ -183,7 +185,7 @@ describe "definingDeclsRdrNames" $ do it "returns [] if not found" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let nm = initRdrNameMap t let Just n = locToNameRdrPure nm (16,6) parsed let decls = GHC.hsmodDecls $ GHC.unLoc parsed @@ -194,7 +196,7 @@ it "finds declarations at the top level" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let nm = initRdrNameMap t let Just n = locToNameRdrPure nm (3,3) parsed @@ -206,7 +208,7 @@ it "finds declarations not at the top level 1" $ do t <- ct $ parsedFileGhc "./LiftToToplevel/WhereIn6.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let nm = initRdrNameMap t let Just n = locToNameRdrPure nm (13,29) parsed @@ -219,7 +221,7 @@ it "finds declarations not at the top level 2" $ do t <- ct $ parsedFileGhc "./LiftToToplevel/LetIn1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let nm = initRdrNameMap t let Just n = locToNameRdrPure nm (11,22) parsed @@ -232,7 +234,7 @@ it "finds in a patbind" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let nm = initRdrNameMap t let Just n = locToNameRdrPure nm (14,1) parsed @@ -260,13 +262,35 @@ -} pending -- "Convert to definingDeclsNames" + -- --------------------------------- + + it "finds a name declared in a RecCon data declaration" $ do + t <- ct $ parsedFileGhc "./Renaming/Field1.hs" + + let + comp = do + parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + nm <- getRefactNameMap + let Just n = locToNameRdrPure nm (5,18) parsed + let rg = definingDeclsRdrNames nm [n] decls False False + return (n,rg) + -- ((bb,resg),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + ((nn,resg),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + + (showGhcQual nn) `shouldBe` "Field1.pointx" + + (showGhcQual resg) `shouldBe` "[data Point\n = Pt {pointx, pointy :: Float}\n deriving (Show)]" + + -- --------------------------------------- -- ------------------------------------------------------------------- {- describe "definingDeclsNames" $ do it "returns [] if not found" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (16,6) parsed @@ -275,8 +299,8 @@ it "finds declarations at the top level" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (3,3) parsed @@ -286,8 +310,8 @@ it "finds in a patbind" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (14,1) parsed @@ -316,7 +340,7 @@ describe "definingSigsRdrNames" $ do it "returns [] if not found" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let nm = initRdrNameMap t let Just n = locToNameRdrPure nm (21,1) parsed @@ -328,7 +352,7 @@ it "finds signatures at the top level" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let nm = initRdrNameMap t let Just n = locToNameRdrPure nm (4,1) parsed @@ -340,7 +364,7 @@ it "returns only the single signature where there are others too" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let nm = initRdrNameMap t let Just n = locToNameRdrPure nm (7,1) parsed @@ -352,7 +376,7 @@ it "finds signatures at lower levels" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let nm = initRdrNameMap t let Just n = locToNameRdrPure nm (16,5) parsed @@ -364,7 +388,7 @@ it "finds multiple signatures 1" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let nm = initRdrNameMap t let Just n1 = locToNameRdrPure nm (21,1) parsed @@ -383,7 +407,7 @@ it "finds multiple signatures 2" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let nm = initRdrNameMap t let Just n1 = locToNameRdrPure nm (14,1) parsed @@ -403,7 +427,7 @@ describe "definingTyClDeclsNames" $ do it "returns [] if not found" $ do t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (10,29) parsed @@ -419,7 +443,7 @@ it "finds family declarations" $ do t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t -- putStrLn $ "parsed:" ++ SYB.showData SYB.Parser 0 parsed @@ -431,7 +455,7 @@ it "finds data declarations" $ do t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (12,6) parsed @@ -440,9 +464,20 @@ -- --------------------------------- + it "finds field names in data declarations" $ do + t <- ct $ parsedFileGhc "./Renaming/Field4.hs" + let parsed = GHC.pm_parsed_source $ tmParsedModule t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (5,23) parsed + let res = definingTyClDeclsNames nm [n] parsed + (unspace $ showGhcQual res) `shouldBe` "[data Vtree a\n = Vleaf {value1 :: a} |\n Vnode {value2 :: a, left, right :: Vtree a}]" + + -- --------------------------------- + it "finds type declarations" $ do t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (14,6) parsed @@ -453,7 +488,7 @@ it "finds class declarations" $ do t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (16,7) parsed @@ -464,7 +499,7 @@ it "finds multiple declarations" $ do t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n1 = locToNameRdrPure nm (14,6) parsed @@ -478,8 +513,8 @@ describe "isFunBindR" $ do it "Returns False if not a function definition" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let decls = getHsDecls parsed @@ -489,9 +524,9 @@ it "Returns True if a function definition" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let (GHC.L _l (GHC.HsModule _name _exps _imps _ds _ _)) = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let (GHC.L _l (GHC.HsModule _name _exps _imps _ds _ _)) = GHC.pm_parsed_source $ tmParsedModule t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just toplevel = getName "DupDef.Dd1.toplevel" renamed @@ -503,8 +538,8 @@ describe "isFunOrPatName" $ do it "return True if a PName is a function/pattern name defined in t" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t -- putStrLn $ "parsed:\n" ++ SYB.showData SYB.Parser 0 parsed @@ -517,8 +552,8 @@ it "return False if a PName is a function/pattern name defined in t" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" t2 <- ct $ parsedFileGhc "./DupDef/Dd2.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed2 = GHC.pm_parsed_source $ GHC.tm_parsed_module t2 + let renamed = tmRenamedSource t + let parsed2 = GHC.pm_parsed_source $ tmParsedModule t2 nm2 = initRdrNameMap t2 let Just tup = getName "DupDef.Dd1.tup" renamed @@ -556,7 +591,7 @@ -- --------------------------------- - it "finds declared HsVar" $ do + it "finds free and declared variables" $ do t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" let comp = do @@ -564,10 +599,9 @@ nm <- getRefactNameMap logDataWithAnns "parsed:" parsed let rr = hsFreeAndDeclaredRdr nm parsed - rg <- hsFreeAndDeclaredPNs parsed - return (rg,rr) - -- ((resg,(FN fr,DN dr)),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - ((resg,(FN fr,DN dr)),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + return rr + -- ((FN fr,DN dr),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + ((FN fr,DN dr),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions -- --------------------- -- Free Vars - parsed @@ -578,7 +612,8 @@ "(GHC.Base.$, (-1, -1)),\n "++ "(GHC.List.head, (-1, -1)), "++ "(GHC.List.zip, (-1, -1)),\n "++ - "(System.IO.getChar, (-1, -1)), "++ + "(GHC.Base.String, (-1, -1)), "++ + "(System.IO.getChar, (-1, -1)),\n "++ "(System.IO.putStrLn, (-1, -1)),\n "++ "(Data.Generics.Text.gshow, (-1, -1))]" @@ -603,42 +638,6 @@ "(FreeAndDeclared.Declare.mkT, (34, 1)),\n "++ "(FreeAndDeclared.Declare.ff, (36, 1))]" - -- --------------------- - -- GHC version - -- Free Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst resg)) `shouldBe` - "[(GHC.Integer.Type.Integer, (-1, -1)), "++ - "(GHC.Num.*, (-1, -1)),\n "++ - "(GHC.Types.Int, (-1, -1)), "++ - "(GHC.Base.$, (-1, -1)),\n "++ - "(GHC.List.head, (-1, -1)), "++ - "(GHC.List.zip, (-1, -1)),\n "++ - "(System.IO.getChar, (-1, -1)), "++ - "(System.IO.putStrLn, (-1, -1)),\n "++ - "(Data.Generics.Text.gshow, (-1, -1))]" - - -- Declared Vars - (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd resg)) `shouldBe` - "[(FreeAndDeclared.Declare.toplevel, (6, 1)),\n "++ - "(FreeAndDeclared.Declare.c, (9, 1)),\n "++ - "(FreeAndDeclared.Declare.d, (10, 1)),\n "++ - "(FreeAndDeclared.Declare.tup, (16, 1)),\n "++ - "(FreeAndDeclared.Declare.h, (16, 6)),\n "++ - "(FreeAndDeclared.Declare.t, (16, 8)),\n "++ - "(FreeAndDeclared.Declare.D, (18, 1)),\n "++ - "(FreeAndDeclared.Declare.A, (18, 10)),\n "++ - "(FreeAndDeclared.Declare.B, (18, 14)),\n "++ - "(FreeAndDeclared.Declare.C, (18, 25)),\n "++ - "(FreeAndDeclared.Declare.unD, (21, 1)),\n "++ - "(FreeAndDeclared.Declare.F, (25, 1)),\n "++ - "(FreeAndDeclared.Declare.G, (25, 10)),\n "++ - "(FreeAndDeclared.Declare.:|, (25, 14)),\n "++ - "(FreeAndDeclared.Declare.unF, (27, 1)),\n "++ - "(FreeAndDeclared.Declare.main, (30, 1)),\n "++ - "(FreeAndDeclared.Declare.mkT, (34, 1)),\n "++ - "(FreeAndDeclared.Declare.ff, (36, 1))]" - - -- --------------------------------- it "finds free and declared in a single bind PrefixCon" $ do @@ -649,7 +648,6 @@ comp = do parsed <- getRefactParsed decls <- liftT $ hsDecls parsed - -- let b = head $ drop 4 $ hsBinds renamed let b = head $ drop 10 $ decls rg <- hsFreeAndDeclaredPNs [b] return (b,rg) @@ -659,7 +657,6 @@ (showGhcQual bb) `shouldBe` "unD (B y) = y" -- (SYB.showData SYB.Renamer 0 bb) `shouldBe` "" - -- GHC version -- Free Vars (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst resg)) `shouldBe` "[(FreeAndDeclared.Declare.B, (18, 14))]" @@ -677,7 +674,6 @@ comp = do parsed <- getRefactParsed decls <- liftT $ hsDecls parsed - -- let b = head $ drop 3 $ hsBinds renamed let b = head $ drop 12 $ decls rg <- hsFreeAndDeclaredPNs [b] return (b,rg) @@ -686,7 +682,6 @@ (showGhcQual bb) `shouldBe` "unF (a :| b) = (a, b)" -- (SYB.showData SYB.Renamer 0 bb) `shouldBe` "" - -- GHC version -- Free Vars (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst resg)) `shouldBe` "[(FreeAndDeclared.Declare.:|, (25, 14))]" @@ -704,7 +699,6 @@ comp = do parsed <- getRefactParsed decls <- liftT $ hsDecls parsed - -- let b = head $ drop 0 $ hsBinds renamed let b = head $ drop 2 decls rg <- hsFreeAndDeclaredPNs [b] return (b,rg) @@ -714,7 +708,6 @@ (showGhcQual bb) `shouldBe` "unR2 (RCon {r1 = a}) = a" -- (SYB.showData SYB.Renamer 0 bb) `shouldBe` "" - -- GHC version -- Free Vars (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst resg)) `shouldBe` "[(FreeAndDeclared.DeclareRec.RCon, (3, 10))]" @@ -723,6 +716,100 @@ (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd resg)) `shouldBe` "[(FreeAndDeclared.DeclareRec.unR2, (7, 1))]" + -- --------------------------------- + + it "finds free and declared in a RecCon data declaration" $ do + t <- ct $ parsedFileGhc "./Renaming/Field1.hs" + + let + comp = do + parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + let b = head $ drop 0 decls + rg <- hsFreeAndDeclaredPNs b + return (b,rg) + -- ((bb,resg),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + ((bb,resg),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + + (showGhcQual bb) `shouldBe` "data Point\n = Pt {pointx, pointy :: Float}\n deriving (Show)" + + -- (SYB.showData SYB.Renamer 0 bb) `shouldBe` "" + + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst resg)) `shouldBe` + "[(GHC.Types.Float, (-1, -1)), "++ + "(GHC.Show.Show, (-1, -1))]" + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd resg)) `shouldBe` + "[(Field1.Point, (5, 1)), "++ + "(Field1.Pt, (5, 14)),\n "++ + "(Field1.pointx, (5, 18)), "++ + "(Field1.pointy, (5, 26))]" + + -- --------------------------------- + + it "finds free and declared in a data declaration, ignoring tyvars 1" $ do + t <- ct $ parsedFileGhc "./Renaming/D1.hs" + + let + comp = do + parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + let b = head $ drop 0 decls + rg <- hsFreeAndDeclaredPNs b + return (b,rg) + -- ((bb,resg),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + ((bb,resg),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + + (showGhcQual bb) `shouldBe` "data Tree a = Leaf a | Branch (Tree a) (Tree a)" + + -- (SYB.showData SYB.Renamer 0 bb) `shouldBe` "" + + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst resg)) `shouldBe` + "[]" + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd resg)) `shouldBe` + "[(Renaming.D1.Tree, (6, 1)), "++ + "(Renaming.D1.Leaf, (6, 15)),\n "++ + "(Renaming.D1.Branch, (6, 24))]" + + + -- --------------------------------- + + it "finds free and declared in a data declaration, ignoring tyvars 2" $ do + t <- ct $ parsedFileGhc "./Renaming/D1.hs" + + let + comp = do + parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + let b = head $ drop 3 decls + rg <- hsFreeAndDeclaredPNs b + return (b,rg) + -- ((bb,resg),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions + ((bb,resg),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + + (showGhcQual bb) `shouldBe` "class SameOrNot c where\n isSame :: c -> c -> Bool\n isNotSame :: c -> c -> Bool" + + -- (SYB.showData SYB.Renamer 0 bb) `shouldBe` "" + + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst resg)) `shouldBe` + "[(GHC.Types.Bool, (-1, -1))]" + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd resg)) `shouldBe` + "[(Renaming.D1.SameOrNot, (12, 1)), "++ + "(Renaming.D1.isSame, (13, 4)),\n "++ + "(Renaming.D1.isNotSame, (14, 4))]" + + -- ----------------------------------------------------------------- it "hsFreeAndDeclaredPNs simplest" $ do @@ -744,7 +831,7 @@ it "finds free and declared in a single bind #2" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t + let renamed = tmRenamedSource t let Just tup = getName "DupDef.Dd1.ff" renamed @@ -777,7 +864,6 @@ let comp = do parsed <- getRefactParsed - -- r <- hsFreeAndDeclaredPNs $ hsBinds renamed r <- hsFreeAndDeclaredPNs parsed return r ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions @@ -818,7 +904,7 @@ it "finds free and declared in a GRHSs" $ do t <- ct $ parsedFileGhc "./LiftOneLevel/LetIn2.hs" - let renamed = fromJust $ GHC.tm_renamed_source t + let renamed = tmRenamedSource t let Just tup = getName "LiftOneLevel.LetIn2.sumSquares" renamed let @@ -882,8 +968,8 @@ it "returns [] if e does not occur in t" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just tl1 = locToExp (4,13) (4,40) parsed :: (Maybe (GHC.Located (GHC.HsExpr GHC.RdrName))) @@ -902,8 +988,8 @@ pendingWith "no longer relevant?" {- t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just tl1 = locToExp (28,4) (28,12) parsed :: (Maybe (GHC.LHsExpr GHC.RdrName)) @@ -929,7 +1015,7 @@ pendingWith "no longer relevant?" {- t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just tl1 = locToExp (28,4) (28,12) parsed :: (Maybe (GHC.LHsExpr GHC.RdrName)) @@ -952,8 +1038,8 @@ pendingWith "no longer relevant?" {- t <- ct $ parsedFileGhc "./Visible/Simple.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let Just e = locToExp (5,11) (5,19) parsed :: (Maybe (GHC.LHsExpr GHC.RdrName)) (showGhcQual e) `shouldBe` "a + b" @@ -978,8 +1064,8 @@ pendingWith "no longer relevant?" {- t <- ct $ parsedFileGhc "./Visible/Simple.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" let Just e = locToExp (9,15) (9,17) parsed :: (Maybe (GHC.LHsExpr GHC.RdrName)) @@ -1003,21 +1089,20 @@ it "finds visible vars inside a function" $ do t <- ct $ parsedFileGhc "./Renaming/IdIn5.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t - let Just rhs = locToExp (14,6) (15,14) parsed :: (Maybe (GHC.LHsExpr GHC.RdrName)) + let Just rhs = locToExp (17,6) (18,14) parsed :: (Maybe (GHC.LHsExpr GHC.RdrName)) (showGhcQual rhs) `shouldBe` "x + y + z" -- let Just er = getName "IdIn5.x" renamed - let Just e = locToRdrName (14,7) parsed + let Just e = locToRdrName (17,7) parsed (showGhcQual e) `shouldBe` "x" - (SYB.showData SYB.Parser 0 e) `shouldBe` "\n(L {Renaming/IdIn5.hs:14:7} \n (Unqual {OccName: x}))" + (SYB.showData SYB.Parser 0 e) `shouldBe` "\n(L {Renaming/IdIn5.hs:17:7} \n (Unqual {OccName: x}))" let comp = do nm <- getRefactNameMap fds' <- hsVisibleDsRdr nm (rdrName2NamePure nm e) rhs - -- ffds <- hsFreeAndDeclaredGhc rhsr let ffds = hsFreeAndDeclaredRdr nm rhs return (fds',ffds) -- ((fds,_fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions @@ -1030,7 +1115,7 @@ it "finds visible vars inside a data declaration" $ do t <- ct $ parsedFileGhc "./Renaming/D1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let Just ln = locToRdrName (6, 6) parsed (showGhcQual ln) `shouldBe` "Tree" @@ -1041,18 +1126,17 @@ -- logDataWithAnns "parsed" parsed nm <- getRefactNameMap fds' <- hsVisibleDsRdr nm (rdrName2NamePure nm ln) parsed - -- ffds <- hsFreeAndDeclaredGhc renamed let ffds = hsFreeAndDeclaredRdr nm parsed return (fds',ffds) ((fds,_fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions -- ((fds,_fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - (show _fds) `shouldBe` "(FN [a, "++ - "GHC.Base.++, "++ + (show _fds) `shouldBe` "(FN [GHC.Base.++, "++ + "GHC.Types.Bool, "++ "GHC.Types.Int, "++ - "GHC.Classes.==, "++ + "GHC.Classes.==,\n "++ "GHC.Classes./=, "++ - ":,\n "++ + ":, "++ "GHC.Num.+, "++ "GHC.Real.^, "++ "[]],"++ @@ -1071,11 +1155,11 @@ it "finds visible vars inIdIn5" $ do t <- ct $ parsedFileGhc "./Renaming/IdIn5.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t - let Just ln = locToRdrName (10, 1) parsed + let Just ln = locToRdrName (13, 1) parsed (showGhcQual ln) `shouldBe` "x" - (SYB.showData SYB.Parser 0 ln) `shouldBe` "\n(L {Renaming/IdIn5.hs:10:1} \n (Unqual {OccName: x}))" + (SYB.showData SYB.Parser 0 ln) `shouldBe` "\n(L {Renaming/IdIn5.hs:13:1} \n (Unqual {OccName: x}))" let comp = do @@ -1087,7 +1171,7 @@ ((fds,_fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions -- ((fds,_fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions - (show _fds) `shouldBe` "(FN [GHC.Num.+],"++ + (show _fds) `shouldBe` "(FN [GHC.Base.String, GHC.Num.+],"++ "DN [IdIn5.x, IdIn5.foo, IdIn5.bar, IdIn5.main])" (show fds) `shouldBe` "DN [GHC.Num.+, IdIn5.x, z, y, IdIn5.foo, IdIn5.bar]" @@ -1098,8 +1182,8 @@ describe "hsFreeAndDeclaredRdr" $ do it "finds function arguments visible in RHS fd" $ do t <- ct $ parsedFileGhc "./Visible/Simple.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just e = locToExp (5,11) (5,19) parsed :: (Maybe (GHC.Located (GHC.HsExpr GHC.RdrName))) @@ -1122,8 +1206,8 @@ it "finds function arguments and free vars visible in RHS" $ do t <- ct $ parsedFileGhc "./Visible/Simple.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just e = locToExp (9,15) (9,17) parsed :: Maybe (GHC.LHsExpr GHC.RdrName) @@ -1144,7 +1228,6 @@ let lpat = head pats logDataWithAnns "lpat" lpat - -- fds' <- hsFreeAndDeclaredGhc $ lpat let fds' = hsFreeAndDeclaredRdr nm lpat return (fds') -- ((fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions @@ -1156,8 +1239,8 @@ it "finds imported functions used in the rhs" $ do t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let Just n = getName "FreeAndDeclared.Declare.tup" renamed @@ -1179,7 +1262,7 @@ it "finds free vars in HsWithBndrs" $ do t <- ct $ parsedFileGhc "./FreeAndDeclared/Binders.hs" - let renamed = fromJust $ GHC.tm_renamed_source t + let renamed = tmRenamedSource t let Just n = getName "FreeAndDeclared.Binders.findNewPName" renamed let @@ -1197,7 +1280,6 @@ let (GHC.L _ (GHC.Match _ _pats _rhs binds)) = match logDataWithAnns "binds" binds - -- fds' <- hsFreeAndDeclaredGhc $ binds let fds' = hsFreeAndDeclaredRdr nm binds return (fds') -- ((fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions @@ -1240,7 +1322,7 @@ describe "isLocalPN" $ do it "returns True if the name is local to the module" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (17, 5) parsed (showGhcQual n) `shouldBe` "ff" @@ -1248,7 +1330,7 @@ it "returns False if the name is not local to the module" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (21, 1) parsed (showGhcQual n) `shouldBe` "DupDef.Dd1.ff" @@ -1289,7 +1371,7 @@ describe "definedPNsRdr" $ do it "gets the PNs defined in a declaration" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just pn = locToNameRdrPure nm (3, 1) parsed @@ -1305,7 +1387,7 @@ it "gets the PNs defined in an as-match" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just pn = locToNameRdrPure nm (14, 1) parsed @@ -1445,7 +1527,7 @@ describe "duplicateDecl" $ do it "duplicates a bind only" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (3, 1) parsed @@ -1467,7 +1549,7 @@ it "duplicates a bind with a signature, and an offset" $ do t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just np = locToNameRdrPure nm (14, 1) parsed @@ -1488,7 +1570,7 @@ (parent',Just (funBinding,declsToDup,declsp')) <- modifyValD (GHC.getLoc parent) parent $ \_m declsp -> do let - declsToDup = definingDeclsRdrNames nm [n] declsp True True + declsToDup = definingDeclsRdrNames nm [n] declsp False True funBinding = filter isFunOrPatBindP declsToDup --get the fun binding. declsp' <- duplicateDecl declsp n newName2 @@ -1517,7 +1599,7 @@ describe "addParamsToDecl" $ do it "adds parameters to a declaration" $ do t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (3, 1) parsed @@ -1540,7 +1622,7 @@ it "adds parameters to a declaration with multiple matches" $ do t <- ct $ parsedFileGhc "./AddParams1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (3, 1) parsed @@ -1562,7 +1644,7 @@ it "adds parameters to a declaration with no existing ones" $ do t <- ct $ parsedFileGhc "./AddParams1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (6, 1) parsed @@ -1586,7 +1668,7 @@ describe "addActualParamsToRhs" $ do it "adds a parameter to the rhs of a declaration" $ do t <- ct $ parsedFileGhc "./LiftToToplevel/D1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (6, 21) parsed @@ -1611,7 +1693,7 @@ it "adds parameters to a complex rhs of a declaration" $ do t <- ct $ parsedFileGhc "./LiftToToplevel/WhereIn7.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (10, 17) parsed @@ -1633,13 +1715,37 @@ (showGhcQual nb) `shouldBe` "fun x y z\n = inc (addthree x1 y1 z1)\n where\n inc a = a + 1\n addthree = x + y + z" (exactPrintFromState s nb) `shouldBe` "\n\n--A definition can be lifted from a where or let to the top level binding group.\n--Lifting a definition widens the scope of the definition.\n\n--In this example, lift 'addthree' defined in 'fun'.\n--This example aims to test adding parenthese.\n\n\nfun x y z =inc (addthree x1 y1 z1)\n where inc a =a +1\n addthree=x+y+z" + -- --------------------------------- + it "adds parameters to a declaration in a tuple" $ do + t <- ct $ parsedFileGhc "./AddParams2.hs" + let parsed = GHC.pm_parsed_source $ tmParsedModule t + nm = initRdrNameMap t + + let Just n = locToNameRdrPure nm (5, 36) parsed + let Just e = locToExp (5,23) (5,47) parsed :: Maybe (GHC.Located (GHC.HsExpr GHC.RdrName)) + let + comp = do + let newName1 = mkRdrName "baz" + let newName2 = mkRdrName "bar" + e' <- addActualParamsToRhs n [newName1,newName2] e + + return e' + (nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions + + (showGhcQual n) `shouldBe` "rightOuter" + (showGhcQual e) `shouldBe` "(rightInner, rightOuter)" + + (exactPrintFromState s nb) `shouldBe` " (rightInner, (rightOuter baz bar))" + -- putStrLn (showAnnDataItemFromState s e) + -- putStrLn (showAnnDataItemFromState s nb) + -- --------------------------------------------- describe "rmDecl" $ do it "removes a top level declaration, leaving type signature 1" $ do t <- ct $ parsedFileGhc "./MoveDef/Md1a.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (6, 1) parsed let @@ -1658,7 +1764,7 @@ it "removes a top level declaration, leaving type signature 2b" $ do t <- ct $ parsedFileGhc "./MoveDef/Md1b.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (6, 1) parsed let @@ -1676,7 +1782,7 @@ it "removes a top level declaration, leaving type signature 2" $ do t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (22, 1) parsed let @@ -1695,7 +1801,7 @@ it "removes a top level declaration, and type signature" $ do t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (22, 1) parsed @@ -1714,7 +1820,7 @@ it "removes the last local decl in a let/in clause" $ do t <- ct $ parsedFileGhc "./LiftToToplevel/LetIn1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (11, 22) parsed @@ -1737,7 +1843,7 @@ it "removes the last local decl in a where clause" $ do t <- ct $ parsedFileGhc "./RmDecl3.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (6, 5) parsed @@ -1758,7 +1864,7 @@ it "removes the first local decl in a where clause" $ do t <- ct $ parsedFileGhc "./RmDecl4.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" @@ -1780,7 +1886,7 @@ it "removes the non last local decl in a let/in clause 1" $ do t <- ct $ parsedFileGhc "./Demote/LetIn1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" @@ -1795,13 +1901,13 @@ -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions (showGhcQual n) `shouldBe` "pow" - (sourceFromState s) `shouldBe` "module Demote.LetIn1 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the local 'pow' to 'sq'\n--This example also aims to test the demoting a local declaration in 'let'.\n\nsumSquares x y = let sq 0=0\n sq z=z^pow\n in sq x + sq y\n\n\nanotherFun 0 y = sq y\n where sq x = x^2\n\n " + (sourceFromState s) `shouldBe` "module Demote.LetIn1 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the local 'pow' to 'sq'\n--This example also aims to test the demoting a local declaration in 'let'.\n\nsumSquares x y = let sq 0=0\n sq z=z^pow\n in sq x + sq y\n\n\nanotherFun 0 y = sq y\n where sq x = x^2\n" -- ----------------------------------- it "removes the non last local decl in a let/in clause 2" $ do t <- ct $ parsedFileGhc "./Demote/LetIn2.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (10, 22) parsed @@ -1821,7 +1927,7 @@ it "removes a decl with a trailing comment" $ do t <- ct $ parsedFileGhc "./Demote/WhereIn3.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (14, 1) parsed let @@ -1840,7 +1946,7 @@ it "removes a sub decl liftOneLevel D1" $ do t <- ct $ parsedFileGhc "./LiftOneLevel/D1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (8, 6) parsed let @@ -1860,7 +1966,7 @@ describe "rmTypeSig" $ do it "removes a type signature from the top level 1" $ do t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (22, 1) parsed let @@ -1879,7 +1985,7 @@ it "removes a type signature from the top level, after decl removed" $ do t <- ct $ parsedFileGhc "./Demote/WhereIn3.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (14, 1) parsed let @@ -1899,7 +2005,7 @@ it "removes a type signature from non-top level" $ do t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (16, 5) parsed let @@ -1918,7 +2024,7 @@ it "removes a type signature within multi signatures 1" $ do t <- ct $ parsedFileGhc "./TypeUtils/TypeSigs.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just b = locToNameRdrPure nm (12, 1) parsed let @@ -1935,7 +2041,7 @@ it "removes a type signature within multi signatures 2" $ do t <- ct $ parsedFileGhc "./TypeUtils/TypeSigs.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (4, 1) parsed let @@ -1955,7 +2061,7 @@ it "removes a type signature within multi signatures 3" $ do t <- ct $ parsedFileGhc "./Demote/WhereIn7.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (12, 1) parsed let @@ -1967,14 +2073,14 @@ ((_nb,os),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions (showGhcQual n) `shouldBe` "WhereIn7.sq" (exactPrintFromState s (fromJust os)) `shouldBe` "\n\nsq :: Int -> Int" - (sourceFromState s) `shouldBe` "module WhereIn7 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--This example also aims to test the split of type signature.\n\nsumSquares x y = sq x + sq y\n\nanotherFun :: Int -> Int\nsq 0 = 0\nsq z = z^pow\n where pow=2\n\nanotherFun x = x^2\n " + (sourceFromState s) `shouldBe` "module WhereIn7 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--This example also aims to test the split of type signature.\n\nsumSquares x y = sq x + sq y\n\nanotherFun :: Int -> Int\nsq 0 = 0\nsq z = z^pow\n where pow=2\n\nanotherFun x = x^2\n" (showGhcQual os) `shouldBe` "Just sq :: Int -> Int" -- ----------------------------------------------------------------- {- it "removes a type signature for a pattern in a bind" $ do t <- ct $ parsedFileGhc "./LiftToToplevel/PatBindIn1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t + let renamed = tmRenamedSource t let Just (GHC.L _ n) = locToName (GHC.mkFastString "./test/testdata/LiftToToplevel/PatBindIn1.hs") (18, 7) renamed let comp = do @@ -2100,7 +2206,7 @@ let Just tl = locToNameRdrPure nm (4, 1) parsed decls <- liftT (hsDecls parsed) let - [tlDecl] = definingDeclsRdrNames nm [tl] decls True False + [tlDecl] = definingDeclsRdrNames nm [tl] decls False False (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") @@ -2127,7 +2233,7 @@ let Just tl = locToNameRdrPure nm (4, 1) parsed decls <- liftT (hsDecls parsed) let - [tlDecl] = definingDeclsRdrNames nm [tl] decls True False + [tlDecl] = definingDeclsRdrNames nm [tl] decls False False (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") (sig, sigAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "sig" "nn :: Int") @@ -2154,7 +2260,7 @@ let Just tl = locToNameRdrPure nm (4, 1) parsed decls <- liftT (hsDecls parsed) let - [tlDecl] = definingDeclsRdrNames nm [tl] decls True False + [tlDecl] = definingDeclsRdrNames nm [tl] decls False False (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") @@ -2179,7 +2285,7 @@ let Just tl = locToNameRdrPure nm (4, 1) parsed decls <- liftT (hsDecls parsed) let - [tlDecl] = definingDeclsRdrNames nm [tl] decls True False + [tlDecl] = definingDeclsRdrNames nm [tl] decls False False (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") @@ -2205,7 +2311,7 @@ let Just tl = locToNameRdrPure nm (4, 1) parsed decls <- liftT (hsDecls parsed) let - [tlDecl] = definingDeclsRdrNames nm [tl] decls True False + [tlDecl] = definingDeclsRdrNames nm [tl] decls False False (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") (sig, sigAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "sig" "nn :: Int") @@ -2354,7 +2460,7 @@ it "replaces a Name with another in limited scope 1" $ do t <- ct $ parsedFileGhc "./TokenTest.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (19, 1) parsed (showGhcQual n) `shouldBe` "TokenTest.foo" @@ -2382,7 +2488,7 @@ it "replace a Name with another in limited scope 2" $ do t <- ct $ parsedFileGhc "./TokenTest.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (19, 1) parsed (showGhcQual n) `shouldBe` "TokenTest.foo" @@ -2411,7 +2517,7 @@ it "replaces a name in a data declaration too" $ do t <- ct $ parsedFileGhc "./Renaming/Field1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (5, 19) parsed @@ -2432,15 +2538,14 @@ -- ((nb,_nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions (showGhcQual n) `shouldBe` "Field1.pointx" - (sourceFromState s) `shouldBe` "module Field1 where\n\n--Rename field name 'pointx' to 'pointx1'\n\ndata Point = Pt {pointx1, pointy :: Float}\n\nabsPoint :: Point -> Float\nabsPoint p = sqrt (pointx1 p * pointx1 p +\n pointy p * pointy p)\n\n" - (unspace $ showGhcQual nb) `shouldBe` "module Field1 where\ndata Point = Pt {pointx1, pointy :: Float}\nabsPoint :: Point -> Float\nabsPoint p = sqrt (pointx1 p * pointx1 p + pointy p * pointy p)" - + (sourceFromState s) `shouldBe` "module Field1 where\n\n--Rename field name 'pointx' to 'pointx1'\n\ndata Point = Pt {pointx1, pointy :: Float} deriving Show\n\nabsPoint :: Point -> Float\nabsPoint p = sqrt (pointx1 p * pointx1 p +\n pointy p * pointy p)\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module Field1 where\ndata Point\n = Pt {pointx1, pointy :: Float}\n deriving (Show)\nabsPoint :: Point -> Float\nabsPoint p = sqrt (pointx1 p * pointx1 p + pointy p * pointy p)" ------------------------------------ it "replaces a name in a type signature too" $ do t <- ct $ parsedFileGhc "./Renaming/Field1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (5, 6) parsed @@ -2459,14 +2564,15 @@ ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule [] t }) testOptions -- ((nb,nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t }) testOptions (showGhcQual n) `shouldBe` "Field1.Point" - (sourceFromState s) `shouldBe` "module Field1 where\n\n--Rename field name 'pointx' to 'pointx1'\n\ndata NewPoint = Pt {pointx, pointy :: Float}\n\nabsPoint :: NewPoint -> Float\nabsPoint p = sqrt (pointx p * pointx p +\n pointy p * pointy p)\n\n" - (unspace $ showGhcQual nb) `shouldBe` "module Field1 where\ndata NewPoint = Pt {pointx, pointy :: Float}\nabsPoint :: NewPoint -> Float\nabsPoint p = sqrt (pointx p * pointx p + pointy p * pointy p)" + (sourceFromState s) `shouldBe` "module Field1 where\n\n--Rename field name 'pointx' to 'pointx1'\n\ndata NewPoint = Pt {pointx, pointy :: Float} deriving Show\n\nabsPoint :: NewPoint -> Float\nabsPoint p = sqrt (pointx p * pointx p +\n pointy p * pointy p)\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module Field1 where\ndata NewPoint\n = Pt {pointx, pointy :: Float}\n deriving (Show)\nabsPoint :: NewPoint -> Float\nabsPoint p = sqrt (pointx p * pointx p + pointy p * pointy p)" + ------------------------------------ it "replace a name in a FunBind with multiple patterns" $ do t <- ct $ parsedFileGhc "./LocToName.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (20, 1) parsed @@ -2489,7 +2595,7 @@ it "replaces a qualified name in a FunBind with multiple patterns" $ do t <- ct $ parsedFileGhc "./LocToName.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t #if __GLASGOW_HASKELL__ <= 710 let modu = GHC.mkModule (GHC.stringToPackageKey "mypackage-1.0") (GHC.mkModuleName "LocToName") @@ -2521,7 +2627,7 @@ it "replaces a parameter name in a FunBind" $ do t <- ct $ parsedFileGhc "./Renaming/LayoutIn2.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (8, 7) parsed @@ -2547,7 +2653,7 @@ it "does not qualify a name in an import hiding clause" $ do t <- ct $ parsedFileGhc "./ScopeAndQual.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t #if __GLASGOW_HASKELL__ <= 710 let modu = GHC.mkModule (GHC.stringToPackageKey "mypackage-1.0") (GHC.mkModuleName "LocToName") @@ -2578,7 +2684,7 @@ it "does not qualify the subject of a type signature" $ do t <- ct $ parsedFileGhc "./Renaming/C7.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t #if __GLASGOW_HASKELL__ <= 710 let modu = GHC.mkModule (GHC.stringToPackageKey "mypackage-1.0") (GHC.mkModuleName "LocToName") @@ -2608,8 +2714,8 @@ it "realigns in a case for a shorter name" $ do t <- ct $ parsedFileGhc "./Renaming/LayoutIn2.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (8, 7) parsed @@ -2636,8 +2742,8 @@ it "realigns in a case for a longer name" $ do t <- ct $ parsedFileGhc "./Renaming/LayoutIn2.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (8, 7) parsed @@ -2663,8 +2769,8 @@ it "realigns in a do for a shorter name" $ do t <- ct $ parsedFileGhc "./Renaming/LayoutIn4.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (7, 8) parsed @@ -2690,8 +2796,8 @@ it "realigns in a do for a longer name" $ do t <- ct $ parsedFileGhc "./Renaming/LayoutIn4.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (7, 8) parsed @@ -2716,8 +2822,8 @@ it "realigns in a where for a shorter name" $ do t <- ct $ parsedFileGhc "./Renaming/LayoutIn1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (7, 17) parsed @@ -2743,8 +2849,8 @@ it "realigns in a where for a longer name" $ do t <- ct $ parsedFileGhc "./Renaming/LayoutIn1.hs" - -- let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + -- let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (7, 17) parsed @@ -2771,8 +2877,8 @@ it "realigns in a let/in for a shorter name" $ do t <- ct $ parsedFileGhc "./TypeUtils/LayoutLet1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (6, 6) parsed @@ -2797,8 +2903,8 @@ it "realigns in a let/in for a longer name 1" $ do t <- ct $ parsedFileGhc "./TypeUtils/LayoutLet1.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (6, 6) parsed @@ -2826,8 +2932,8 @@ it "realigns in a let/in for a longer name 2" $ do t <- ct $ parsedFileGhc "./TypeUtils/LayoutLet2.hs" - let renamed = fromJust $ GHC.tm_renamed_source t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = tmRenamedSource t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (7, 6) parsed @@ -2854,7 +2960,7 @@ it "renames an exported data type" $ do t <- ct $ parsedFileGhc "./Renaming/RenameInExportedType2.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (6, 24) parsed @@ -2880,7 +2986,7 @@ it "renames a qualified usage of a name" $ do t <- ct $ parsedFileGhc "./Renaming/QualClient.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (10, 10) parsed @@ -2906,7 +3012,7 @@ it "renames a class op signature" $ do t <- ct $ parsedFileGhc "./Renaming/D4.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (13, 5) parsed @@ -2933,7 +3039,7 @@ it "renames a data decl parameter" $ do t <- ct $ parsedFileGhc "./Renaming/ConstructorIn3.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (9, 13) parsed @@ -2961,7 +3067,7 @@ describe "qualifyToplevelName" $ do it "qualifies a name at the top level" $ do t <- ct $ parsedFileGhc "./Renaming/C7.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t nm = initRdrNameMap t let Just n = locToNameRdrPure nm (7, 1) parsed @@ -3124,24 +3230,24 @@ describe "modIsExported" $ do it "Returns True if the module is explicitly exported" $ do t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ tmParsedModule t + let renamed = tmRenamedSource t let (Just (modName,_)) = getModuleName parsed (modIsExported modName renamed) `shouldBe` True it "Returns True if the module is exported by default" $ do t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare1.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ tmParsedModule t + let renamed = tmRenamedSource t let (Just (modName,_)) = getModuleName parsed (modIsExported modName renamed) `shouldBe` True it "Returns False if the module is explicitly not exported" $ do t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare2.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t - let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ tmParsedModule t + let renamed = tmRenamedSource t let (Just (modName,_)) = getModuleName parsed (modIsExported modName renamed) `shouldBe` False @@ -3180,13 +3286,10 @@ comp = do clearParsedModule t2 <- parseSourceFileTest "./DupDef/Dd2.hs" - let renamed2 = fromJust $ GHC.tm_renamed_source t2 - - let parsed1 = GHC.pm_parsed_source $ GHC.tm_parsed_module t1 - let parsed2 = GHC.pm_parsed_source $ GHC.tm_parsed_module t2 + let renamed2 = tmRenamedSource t2 - -- let mn = locToName (4,1) renamed1 - -- let (Just (GHC.L _ _n)) = mn + let parsed1 = GHC.pm_parsed_source $ tmParsedModule t1 + let parsed2 = GHC.pm_parsed_source $ tmParsedModule t2 let Just (modName,_) = getModuleName parsed1 let @@ -3199,6 +3302,8 @@ ((_r,_r2),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule [] t1}) testOptions -- ((_r,_r2),s) <- ct $ runRefactGhc comp (initialLogOnState { rsModule = initRefactModule [] t1}) testOptions + -- putStrLn $ showAnnDataFromState s + (sourceFromState s) `shouldBe` "module DupDef.Dd2 where\n\nimport DupDef.Dd1 hiding (n1,n2)\n\n\nf2 x = ff (x+1)\n\nmm = 5\n\n\n" ------------------------------------ @@ -3210,10 +3315,10 @@ clearParsedModule t2 <- parseSourceFileTest "./DupDef/Dd3.hs" - let renamed2 = fromJust $ GHC.tm_renamed_source t2 + let renamed2 = tmRenamedSource t2 - let parsed1 = GHC.pm_parsed_source $ GHC.tm_parsed_module t1 - let parsed2 = GHC.pm_parsed_source $ GHC.tm_parsed_module t2 + let parsed1 = GHC.pm_parsed_source $ tmParsedModule t1 + let parsed2 = GHC.pm_parsed_source $ tmParsedModule t2 -- let mn = locToName (4,1) renamed1 -- let (Just (GHC.L _ _n)) = mn @@ -3349,9 +3454,9 @@ t <- ct $ parsedFileGhc "./Renaming/ConflictExport.hs" let nm = initRdrNameMap t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t - let modu = GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module t + let modu = GHC.ms_mod $ GHC.pm_mod_summary $ tmParsedModule t -- Is this the right module? let Just (modName,_) = getModuleName parsed @@ -3363,7 +3468,8 @@ -- new name is "Renaming.ConflictExport.fringe" let newName = mkTestGhcName 1 (Just modu) "fringe" - (showGhcQual modu) `shouldBe` "main@main:Renaming.ConflictExport" + -- (showGhcQual modu) `shouldBe` "main@main:Renaming.ConflictExport" + (showGhc modu) `shouldBe` "Renaming.ConflictExport" (showGhcQual newName) `shouldBe` "Renaming.ConflictExport.fringe" (showGhcQual $ GHC.localiseName newName) `shouldBe` "fringe" @@ -3374,9 +3480,9 @@ it "Returns False if there is no clash" $ do t <- ct $ parsedFileGhc "./Renaming/ConflictExport.hs" let nm = initRdrNameMap t - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t - let modu = GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module t + let modu = GHC.ms_mod $ GHC.pm_mod_summary $ tmParsedModule t -- Is this the right module? let Just (modName,_) = getModuleName parsed @@ -3388,7 +3494,8 @@ -- new name is "Renaming.ConflictExport.fringe" let newName = mkTestGhcName 1 (Just modu) "fringeOk" - (showGhcQual modu) `shouldBe` "main@main:Renaming.ConflictExport" + -- (showGhcQual modu) `shouldBe` "main@main:Renaming.ConflictExport" + (showGhc modu) `shouldBe` "Renaming.ConflictExport" (showGhcQual newName) `shouldBe` "Renaming.ConflictExport.fringeOk" (showGhcQual $ GHC.localiseName newName) `shouldBe` "fringeOk" @@ -3510,7 +3617,7 @@ let comp = do - let renamed1 = fromJust $ GHC.tm_renamed_source t + let renamed1 = tmRenamedSource t parsed <- getRefactParsed let listModName = GHC.mkModuleName "Data.List" @@ -3527,7 +3634,7 @@ t <- ct $ parsedFileGhc "./TypeUtils/JustImports.hs" let comp = do - let renamed1 = fromJust $ GHC.tm_renamed_source t + let renamed1 = tmRenamedSource t parsed <- getRefactParsed let listModName = GHC.mkModuleName "Data.List" @@ -3586,7 +3693,7 @@ comp = do (t1,_toks1) <- parseSourceFileTest "./TypeUtils/JustImports.hs" -- clearParsedModule - let renamed1 = fromJust $ GHC.tm_renamed_source t1 + let renamed1 = tmRenamedSource t1 let modName = GHC.mkModuleName "Data.Maybe" itemName <- mkNewGhcName Nothing "fromJust" @@ -3626,7 +3733,7 @@ comp = do (t1,_toks1) <- parseSourceFileTest "./TypeUtils/SelectivelyImports.hs" -- clearParsedModule - let renamed1 = fromJust $ GHC.tm_renamed_source t1 + let renamed1 = tmRenamedSource t1 let modName = GHC.mkModuleName "Data.Maybe" itemName <- mkNewGhcName Nothing "isJust" @@ -3644,7 +3751,7 @@ comp = do (t1,_toks1) <- parseSourceFileTest "./TypeUtils/SelectivelyImports.hs" -- clearParsedModule - let renamed1 = fromJust $ GHC.tm_renamed_source t1 + let renamed1 = tmRenamedSource t1 let modName = GHC.mkModuleName "Data.Maybe" itemName <- mkNewGhcName Nothing "isJust" @@ -3680,7 +3787,7 @@ describe "isFieldName" $ do it "returns True if a Name is a field name" $ do t <- ct $ parsedFileGhc "./Renaming/Field3.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let nm = initRdrNameMap t let Just nf = locToNameRdrPure nm (10,21) parsed @@ -3694,7 +3801,7 @@ describe "name predicates" $ do it "classifies names" $ do t <- ct $ parsedFileGhc "./Cons.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let nm = initRdrNameMap t let Just n1 = locToNameRdrPure nm (3,6) parsed @@ -3744,7 +3851,7 @@ it "finds a Name for a top-level RdrName" $ do t <- ct $ parsedFileGhc "./TokenTest.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let comp = do @@ -3761,7 +3868,7 @@ it "finds a Name for a local RdrName" $ do t <- ct $ parsedFileGhc "./TokenTest.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let comp = do @@ -3773,7 +3880,7 @@ (showGhcQual (r,n)) `shouldBe` "(bar, bar)" - -- --------------------------------------- + -- --------------------------------------------------------------------- myShow :: GHC.RdrName -> String myShow n = case n of diff --git a/test/UtilsSpec.hs b/test/UtilsSpec.hs --- a/test/UtilsSpec.hs +++ b/test/UtilsSpec.hs @@ -22,6 +22,7 @@ import Language.Haskell.Refact.Utils.Monad import Language.Haskell.Refact.Utils.MonadFunctions import Language.Haskell.Refact.Utils.TypeUtils +import Language.Haskell.Refact.Utils.Types import Language.Haskell.Refact.Utils.Utils import Language.Haskell.Refact.Utils.Variables @@ -41,7 +42,7 @@ describe "locToExp on ParsedSource" $ do it "p:finds the largest leftmost expression contained in a given region #1" $ do t <- ct $ parsedFileGhc "./TypeUtils/B.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let (Just expr) = locToExp (7,7) (7,43) parsed :: Maybe (GHC.Located (GHC.HsExpr GHC.RdrName)) getLocatedStart expr `shouldBe` (7,9) @@ -50,7 +51,7 @@ it "p:finds the largest leftmost expression contained in a given region #2" $ do -- ((_, _, mod), toks) <- parsedFileBGhc t <- ct $ parsedFileGhc "./TypeUtils/B.hs" - let modu = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let modu = GHC.pm_parsed_source $ tmParsedModule t let (Just expr) = locToExp (7,7) (7,41) modu :: Maybe (GHC.Located (GHC.HsExpr GHC.RdrName)) getLocatedStart expr `shouldBe` (7,12) @@ -58,7 +59,7 @@ it "finds the largest leftmost expression in RenamedSource" $ do t <- ct $ parsedFileGhc "./TypeUtils/B.hs" - let renamed = fromJust $ GHC.tm_renamed_source t + let renamed = tmRenamedSource t let (Just expr) = locToExp (7,7) (7,41) renamed :: Maybe (GHC.Located (GHC.HsExpr GHC.Name)) getLocatedStart expr `shouldBe` (7,12) @@ -68,7 +69,7 @@ it "r:finds the largest leftmost expression contained in a given region #1" $ do -- ((_, Just renamed, _), toks) <- parsedFileBGhc t <- ct $ parsedFileGhc "./TypeUtils/B.hs" - let renamed = fromJust $ GHC.tm_renamed_source t + let renamed = tmRenamedSource t let (Just expr) = locToExp (7,7) (7,43) renamed :: Maybe (GHC.Located (GHC.HsExpr GHC.Name)) getLocatedStart expr `shouldBe` (7,9) @@ -80,14 +81,14 @@ it "loads a file having the LANGUAGE CPP pragma" $ do t <- ct $ parsedFileGhc "./BCpp.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t (showGhc parsed) `shouldBe` "module BCpp where\nbob :: Int -> Int -> Int\nbob x y = x + y" -- --------------------------------- it "loads a file having a top comment and LANGUAGE CPP pragma" $ do t <- ct $ parsedFileGhc "./BCppTC.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t (showGhc parsed) `shouldBe` "module BCppTC where\nbob :: Int -> Int -> Int\nbob x y = x + y" -- --------------------------------- @@ -149,6 +150,30 @@ -- ----------------------------------- + it "loads a file without a cabal project" $ do + + tmp <- getTemporaryDirectory + let testDir = tmp ++ "/hare-test-no-cabal" + testFileName = testDir ++ "/Foo.hs" + testFileContents = unlines + [ "main = putStrLn \"helo\"" + , "x = 1" + ] + createDirectoryIfMissing True testDir + writeFile testFileName testFileContents + + let + comp = do + parseSourceFileGhc testFileName + tm <- getRefactTargetModule + g <- clientModsAndFiles tm + return g + (mg,_s) <- cdAndDo testDir $ runRefactGhc comp initialState testOptions + -- (mg,_s) <- cdAndDo testDir $ runRefactGhc comp initialLogOnState testOptions + showGhc (map GM.mpModule mg) `shouldBe` "[]" + + -- ----------------------------------- + it "loads a series of files based on cabal3, which has a lib and an exe" $ do currentDir <- getCurrentDirectory @@ -332,14 +357,14 @@ describe "getModuleName" $ do it "returns a string for the module name if there is one" $ do t <- ct $ parsedFileGhc "./TypeUtils/B.hs" - let modu = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let modu = GHC.pm_parsed_source $ tmParsedModule t let (Just (_modname,modNameStr)) = getModuleName modu modNameStr `shouldBe` "TypeUtils.B" it "returns Nothing for the module name otherwise" $ do t <- ct $ parsedFileGhc "./NoMod.hs" - let modu = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let modu = GHC.pm_parsed_source $ tmParsedModule t getModuleName modu `shouldBe` Nothing -- ------------------------------------------------------------------- @@ -366,7 +391,7 @@ return g (mg,_s) <- ct $ runRefactGhc comp initialState testOptions -- (mg,_s) <- ct $ runRefactGhc comp initialLogOnState testOptions - showGhc (map GM.mpModule mg) `shouldBe` "[Main, M3, M2]" + (sort $ map (showGhc . GM.mpModule) mg) `shouldBe` ["M2", "M3", "Main"] ------------------------------------ @@ -399,6 +424,38 @@ ------------------------------------ + it "gets modules when loading without a cabal file" $ do + + tmp <- getTemporaryDirectory + let testDir = tmp ++ "/hare-test-no-cabal-clientmodsandfiles" + testFileBName = testDir ++ "/B.hs" + testFileFooName = testDir ++ "/Foo.hs" + testFileBContents = unlines + [ "module B where" + , "y = 2" + ] + testFileFooContents = unlines + [ "import B" + , "main = putStrLn \"hello\"" + , "x = y + 1" + ] + createDirectoryIfMissing True testDir + writeFile testFileBName testFileBContents + writeFile testFileFooName testFileFooContents + + let + comp = do + parseSourceFileGhc "./Foo.hs" -- Load the file first + parseSourceFileGhc "./B.hs" -- Load the file first + tm <- getRefactTargetModule + g <- clientModsAndFiles tm + return g + (mg,_s) <- cdAndDo testDir $ runRefactGhc comp initialState testOptions + showGhc (map GM.mpModule mg) `shouldBe` "[]" + + + ------------------------------------ + it "gets modules for HaRe" $ do {- let @@ -483,10 +540,10 @@ return (pr,g) ( (t, mg), _s) <- ct $ runRefactGhc comp initialState testOptions - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t (show $ getModuleName parsed) `shouldBe` "Just (ModuleName \"S1\",\"S1\")" - showGhc (map GM.mpModule mg) `shouldBe` "[Main, M3, M2]" + (sort $ map (showGhc . GM.mpModule) mg) `shouldBe` ["M2", "M3", "Main"] -- --------------------------------- @@ -500,10 +557,10 @@ return (pr,g) ((t, mg ), _s) <- ct $ runRefactGhc comp initialState testOptions - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t (show $ getModuleName parsed) `shouldBe` "Just (ModuleName \"S1\",\"S1\")" - showGhc (map GM.mpModule mg) `shouldBe` "[Main, M3, M2]" + (sort $ map (showGhc . GM.mpModule) mg) `shouldBe` ["M2", "M3", "Main"] -- --------------------------------- @@ -517,7 +574,7 @@ return (pr,g) ((t, mg), _s) <- ct $ runRefactGhc comp initialState testOptions - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t (show $ getModuleName parsed) `shouldBe` "Just (ModuleName \"DupDef.Dd1\",\"DupDef.Dd1\")" showGhc (map GM.mpModule mg) `shouldBe` "[DupDef.Dd2, DupDef.Dd3]" @@ -582,7 +639,7 @@ it "loads a file from a sub directory" $ do t <- ct $ parsedFileGhc "./FreeAndDeclared/DeclareS.hs" fileName <- canonicalizePath "./test/testdata/FreeAndDeclared/DeclareS.hs" - let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let parsed = GHC.pm_parsed_source $ tmParsedModule t let comp = do parseSourceFileGhc fileName diff --git a/test/testdata/AddOneParameter/FunIn6.expected.hs b/test/testdata/AddOneParameter/FunIn6.expected.hs --- a/test/testdata/AddOneParameter/FunIn6.expected.hs +++ b/test/testdata/AddOneParameter/FunIn6.expected.hs @@ -1,4 +1,4 @@ -module FunIn6 where +module AddOneParameter.FunIn6 where --Default parameters can be added to definition of functions and simple constants. diff --git a/test/testdata/AddOneParameter/FunIn6.hs b/test/testdata/AddOneParameter/FunIn6.hs --- a/test/testdata/AddOneParameter/FunIn6.hs +++ b/test/testdata/AddOneParameter/FunIn6.hs @@ -1,4 +1,4 @@ -module FunIn6 where +module AddOneParameter.FunIn6 where --Default parameters can be added to definition of functions and simple constants. diff --git a/test/testdata/AddParams2.hs b/test/testdata/AddParams2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddParams2.hs @@ -0,0 +1,5 @@ +module AddParams2 where + +collapse rightInner rightOuter = right + where + right = (rightInner, rightOuter) diff --git a/test/testdata/Demote/CaseIn1.hs b/test/testdata/Demote/CaseIn1.hs --- a/test/testdata/Demote/CaseIn1.hs +++ b/test/testdata/Demote/CaseIn1.hs @@ -10,9 +10,7 @@ --show that lifting and demoting are not inverse. main x y z = case x of - 0 -> addthree x y z - 1 -> inc y + 0 -> addthree x y z + 1 -> inc y where inc a =a+1 addthree a b c=a+b+c - - diff --git a/test/testdata/Demote/CaseIn1.hs.expected b/test/testdata/Demote/CaseIn1.hs.expected --- a/test/testdata/Demote/CaseIn1.hs.expected +++ b/test/testdata/Demote/CaseIn1.hs.expected @@ -15,5 +15,3 @@ where inc a =a+1 where addthree=x+y+z - - diff --git a/test/testdata/Demote/D2.hs.expected b/test/testdata/Demote/D2.hs.expected deleted file mode 100644 --- a/test/testdata/Demote/D2.hs.expected +++ /dev/null @@ -1,12 +0,0 @@ -module Demote.D2 where - -sq x = x ^pow - -pow = 2 - -main = sumSquares [1..4] - where - --demote 'sumSquares' should fail as it used by module 'A2'. - sumSquares (x:xs) = sq x + sumSquares xs - sumSquares [] = 0 - diff --git a/test/testdata/Demote/D2a.hs b/test/testdata/Demote/D2a.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/D2a.hs @@ -0,0 +1,13 @@ +module Demote.D2a where + +--demote 'sumSquares' should fail as it used by module 'A2'. + +sumSquares (x:xs) = sq x + sumSquares xs +sumSquares [] = 0 + +sq x = x ^pow + +pow = 2 + +main = sumSquares [1..4] + diff --git a/test/testdata/Demote/D2a.hs.expected b/test/testdata/Demote/D2a.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/D2a.hs.expected @@ -0,0 +1,12 @@ +module Demote.D2a where + +sq x = x ^pow + +pow = 2 + +main = sumSquares [1..4] + where + --demote 'sumSquares' should fail as it used by module 'A2'. + sumSquares (x:xs) = sq x + sumSquares xs + sumSquares [] = 0 + diff --git a/test/testdata/Demote/LetIn1.hs b/test/testdata/Demote/LetIn1.hs --- a/test/testdata/Demote/LetIn1.hs +++ b/test/testdata/Demote/LetIn1.hs @@ -10,10 +10,8 @@ sumSquares x y = let sq 0=0 sq z=z^pow pow=2 - in sq x + sq y - - + in sq x + sq y + + anotherFun 0 y = sq y where sq x = x^2 - - diff --git a/test/testdata/Demote/LetIn1.hs.expected b/test/testdata/Demote/LetIn1.hs.expected --- a/test/testdata/Demote/LetIn1.hs.expected +++ b/test/testdata/Demote/LetIn1.hs.expected @@ -16,5 +16,3 @@ anotherFun 0 y = sq y where sq x = x^2 - - diff --git a/test/testdata/Demote/WhereIn7.hs b/test/testdata/Demote/WhereIn7.hs --- a/test/testdata/Demote/WhereIn7.hs +++ b/test/testdata/Demote/WhereIn7.hs @@ -7,12 +7,11 @@ --In this example, demote the top level 'sq' to 'sumSquares' --This example also aims to test the split of type signature. -sumSquares x y = sq x + sq y +sumSquares x y = sq x + sq y sq,anotherFun :: Int -> Int sq 0 = 0 -sq z = z^pow +sq z = z^pow where pow=2 anotherFun x = x^2 - diff --git a/test/testdata/Demote/WhereIn7.hs.expected b/test/testdata/Demote/WhereIn7.hs.expected --- a/test/testdata/Demote/WhereIn7.hs.expected +++ b/test/testdata/Demote/WhereIn7.hs.expected @@ -17,4 +17,3 @@ anotherFun :: Int -> Int anotherFun x = x^2 - diff --git a/test/testdata/FreeAndDeclared/Declare.hs b/test/testdata/FreeAndDeclared/Declare.hs --- a/test/testdata/FreeAndDeclared/Declare.hs +++ b/test/testdata/FreeAndDeclared/Declare.hs @@ -4,7 +4,7 @@ toplevel :: Integer -> Integer toplevel x = c * x - + c,d :: Integer c = 7 d = 9 diff --git a/test/testdata/FreeAndDeclared/Declare2.hs b/test/testdata/FreeAndDeclared/Declare2.hs --- a/test/testdata/FreeAndDeclared/Declare2.hs +++ b/test/testdata/FreeAndDeclared/Declare2.hs @@ -4,7 +4,7 @@ toplevel :: Integer -> Integer toplevel x = c * x - + c,d :: Integer c = 7 d = 9 diff --git a/test/testdata/LiftToToplevel/PatBindIn2.hs b/test/testdata/LiftToToplevel/PatBindIn2.hs --- a/test/testdata/LiftToToplevel/PatBindIn2.hs +++ b/test/testdata/LiftToToplevel/PatBindIn2.hs @@ -1,4 +1,4 @@ -module PatBindIn2 where +module LiftToToplevel.PatBindIn2 where --A definition can be lifted from a where or let into the surrounding binding group. --Lifting a definition widens the scope of the definition. diff --git a/test/testdata/LiftToToplevel/PatBindIn4.hs b/test/testdata/LiftToToplevel/PatBindIn4.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/PatBindIn4.hs @@ -0,0 +1,12 @@ +module LiftToToplevel.PatBindIn4 where + +-- Issue https://github.com/RefactoringTools/HaRe/issues/42 +-- liftToTopLevel of a should fail. +-- Alternatively, it should result in something like +{- +f x = a x +a x = fst (x, x) +b x = snd (x, x) +-} + +f x = let (a, b) = (x, x) in a diff --git a/test/testdata/Renaming/Constructor.expected.hs b/test/testdata/Renaming/Constructor.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Constructor.expected.hs @@ -0,0 +1,9 @@ +module Constructor where + +-- Should be able to rename AType to MyType, as they are in different name +-- spaces +data MyType = MyType Int | YourType Bool + +foo :: MyType -> Bool +foo (MyType i) = i > 0 +foo (YourType b) = b diff --git a/test/testdata/Renaming/Constructor.hs b/test/testdata/Renaming/Constructor.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Constructor.hs @@ -0,0 +1,9 @@ +module Constructor where + +-- Should be able to rename AType to MyType, as they are in different name +-- spaces +data MyType = AType Int | YourType Bool + +foo :: MyType -> Bool +foo (AType i) = i > 0 +foo (YourType b) = b diff --git a/test/testdata/Renaming/D1.hs b/test/testdata/Renaming/D1.hs --- a/test/testdata/Renaming/D1.hs +++ b/test/testdata/Renaming/D1.hs @@ -5,17 +5,17 @@ data Tree a = Leaf a | Branch (Tree a) (Tree a) -fringe :: Tree a -> [a] +fringe :: Tree b -> [b] fringe (Leaf x ) = [x] fringe (Branch left right) = fringe left ++ fringe right -class SameOrNot a where - isSame :: a -> a -> Bool - isNotSame :: a -> a -> Bool +class SameOrNot c where + isSame :: c -> c -> Bool + isNotSame :: c -> c -> Bool instance SameOrNot Int where - isSame a b = a == b - isNotSame a b = a /= b + isSame d e = d == e + isNotSame d e = d /= e sumSquares (x:xs) = sq x + sumSquares xs where sq x = x ^pow diff --git a/test/testdata/Renaming/D1.hs.expected b/test/testdata/Renaming/D1.hs.expected --- a/test/testdata/Renaming/D1.hs.expected +++ b/test/testdata/Renaming/D1.hs.expected @@ -5,17 +5,17 @@ data AnotherTree a = Leaf a | Branch (AnotherTree a) (AnotherTree a) -fringe :: AnotherTree a -> [a] +fringe :: AnotherTree b -> [b] fringe (Leaf x ) = [x] fringe (Branch left right) = fringe left ++ fringe right -class SameOrNot a where - isSame :: a -> a -> Bool - isNotSame :: a -> a -> Bool +class SameOrNot c where + isSame :: c -> c -> Bool + isNotSame :: c -> c -> Bool instance SameOrNot Int where - isSame a b = a == b - isNotSame a b = a /= b + isSame d e = d == e + isNotSame d e = d /= e sumSquares (x:xs) = sq x + sumSquares xs where sq x = x ^pow diff --git a/test/testdata/Renaming/ExportedType.expected.hs b/test/testdata/Renaming/ExportedType.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/ExportedType.expected.hs @@ -0,0 +1,4 @@ +module Renaming.ExportedType where + +-- Same constructor name as the type name, check we can choose the right one in a client module +data NewType = MyType Int diff --git a/test/testdata/Renaming/ExportedType.hs b/test/testdata/Renaming/ExportedType.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/ExportedType.hs @@ -0,0 +1,4 @@ +module Renaming.ExportedType where + +-- Same constructor name as the type name, check we can choose the right one in a client module +data MyType = MyType Int diff --git a/test/testdata/Renaming/ExportedTypeClient.expected.hs b/test/testdata/Renaming/ExportedTypeClient.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/ExportedTypeClient.expected.hs @@ -0,0 +1,9 @@ + +import Renaming.ExportedType + +-- renaming must distinguish between type name and constructor name +foo :: NewType -> Bool +foo (MyType 0) = True +foo (MyType _) = False + +main = putStrLn "hello" diff --git a/test/testdata/Renaming/ExportedTypeClient.hs b/test/testdata/Renaming/ExportedTypeClient.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/ExportedTypeClient.hs @@ -0,0 +1,9 @@ + +import Renaming.ExportedType + +-- renaming must distinguish between type name and constructor name +foo :: MyType -> Bool +foo (MyType 0) = True +foo (MyType _) = False + +main = putStrLn "hello" diff --git a/test/testdata/Renaming/Field1.hs b/test/testdata/Renaming/Field1.hs --- a/test/testdata/Renaming/Field1.hs +++ b/test/testdata/Renaming/Field1.hs @@ -2,7 +2,7 @@ --Rename field name 'pointx' to 'pointx1' -data Point = Pt {pointx, pointy :: Float} +data Point = Pt {pointx, pointy :: Float} deriving Show absPoint :: Point -> Float absPoint p = sqrt (pointx p * pointx p + diff --git a/test/testdata/Renaming/Field1.hs.expected b/test/testdata/Renaming/Field1.hs.expected --- a/test/testdata/Renaming/Field1.hs.expected +++ b/test/testdata/Renaming/Field1.hs.expected @@ -2,7 +2,7 @@ --Rename field name 'pointx' to 'pointx1' -data Point = Pt {pointx1, pointy :: Float} +data Point = Pt {pointx1, pointy :: Float} deriving Show absPoint :: Point -> Float absPoint p = sqrt (pointx1 p * pointx1 p + diff --git a/test/testdata/Renaming/Field1_TokOut.hs b/test/testdata/Renaming/Field1_TokOut.hs deleted file mode 100644 --- a/test/testdata/Renaming/Field1_TokOut.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Field1 where - ---Rename field name 'pointx' to 'pointx1' - -data Point = Pt {pointx1, pointy :: Float} - -absPoint :: Point -> Float -absPoint p = sqrt (pointx1 p * pointx1 p + - pointy p * pointy p) - diff --git a/test/testdata/Renaming/Field4.hs b/test/testdata/Renaming/Field4.hs --- a/test/testdata/Renaming/Field4.hs +++ b/test/testdata/Renaming/Field4.hs @@ -2,7 +2,7 @@ --Rename field name 'value1' to 'value2' should success. -data Vtree a = Vleaf {value1::a} | +data Vtree a = Vleaf {value1::a} | Vnode {value2::a, left,right ::Vtree a} fringe :: Vtree a -> [a] diff --git a/test/testdata/Renaming/IdIn5.hs b/test/testdata/Renaming/IdIn5.hs --- a/test/testdata/Renaming/IdIn5.hs +++ b/test/testdata/Renaming/IdIn5.hs @@ -1,5 +1,8 @@ module IdIn5 where +-- Check that annotation can be processed properly too +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} + {-To rename an identifier name, stop the cursor at any occurrence of the name, then input the new name in the mini-buffer, after that, select the 'rename' command from the 'Refactor' menu.-} diff --git a/test/testdata/Renaming/InScopes.hs b/test/testdata/Renaming/InScopes.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/InScopes.hs @@ -0,0 +1,21 @@ +module Renaming.InScopes where + +-- based on https://github.com/RefactoringTools/HaRe/issues/41 + +-- renaming x to g should fail for a name clash, in all cases +f x = let g = 'g' in x + +f1 x = do + let g = 'g' + return x + +f2 x = x + where + g = 'g' + +-- Renaming f to g should also fail, esp when the initial point is the function +-- definition for f +f3 x = y + where + g = f 'g' + y = f2 x diff --git a/test/testdata/Renaming/LayoutIn3.hs b/test/testdata/Renaming/LayoutIn3.hs --- a/test/testdata/Renaming/LayoutIn3.hs +++ b/test/testdata/Renaming/LayoutIn3.hs @@ -7,7 +7,6 @@ foo x = let x = 12 in (let y = 3 z = 2 in x * y * z * w) where y = 2 --there is a comment. - w = x + w = x where x = let y = 5 in y + 3 - diff --git a/test/testdata/Renaming/LayoutIn3.hs.expected b/test/testdata/Renaming/LayoutIn3.hs.expected --- a/test/testdata/Renaming/LayoutIn3.hs.expected +++ b/test/testdata/Renaming/LayoutIn3.hs.expected @@ -10,4 +10,3 @@ w = x where x = let y = 5 in y + 3 - diff --git a/test/testdata/Renaming/WildCard.expected.hs b/test/testdata/Renaming/WildCard.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/WildCard.expected.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PartialTypeSignatures #-} + +module Renaming.WildCard where + +-- | This will be read from a configuration, eventually +taggedPlugins2 :: Plugin _ +taggedPlugins2 = undefined + +data Plugin a = Plugin a + diff --git a/test/testdata/Renaming/WildCard.hs b/test/testdata/Renaming/WildCard.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/WildCard.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PartialTypeSignatures #-} + +module Renaming.WildCard where + +-- | This will be read from a configuration, eventually +taggedPlugins :: Plugin _ +taggedPlugins = undefined + +data Plugin a = Plugin a + diff --git a/test/testdata/testdata.cabal b/test/testdata/testdata.cabal --- a/test/testdata/testdata.cabal +++ b/test/testdata/testdata.cabal @@ -1,4 +1,4 @@ -Name: HaRe-tests +Name: testdata Version: 0 Author: Alan Zimmerman Maintainer: Alan Zimmerman @@ -6,6 +6,35 @@ Build-Type: Simple -- Other-Extensions: CPP +Library + Hs-Source-Dirs: . + Build-Depends: base + , syb + GHC-Options: -W + default-language: Haskell2010 + +Executable RenamingMain + Main-Is: ./Renaming/Main.hs + Hs-Source-Dirs: . + Build-Depends: base >= 4.0 && < 5 + , syb + GHC-Options: -W + default-language: Haskell2010 + +Executable RenamingMain2 + Main-Is: ./Renaming/Main2.hs + Hs-Source-Dirs: . + Build-Depends: base >= 4.0 && < 5 + , syb + default-language: Haskell2010 + +Executable RenamingExportedType + Main-Is: ./Renaming/ExportedTypeClient.hs + Hs-Source-Dirs: . + Build-Depends: base >= 4.0 && < 5 + , syb + default-language: Haskell2010 + Executable bcpp Main-Is: BCpp.hs Build-Depends: base >= 4.0 && < 5 @@ -157,6 +186,12 @@ -- --------------------------------------------------------------------- +Executable deldef2 + Main-Is: DeleteDef/Dd2Client.hs + Other-Modules : DeleteDef.Dd2 + Build-Depends: base >= 4.0 && < 5 + default-language: Haskell2010 + Executable addoneparama1 Main-Is: AddOneParameter/A1.hs Other-Modules : AddOneParameter.C1 @@ -194,3 +229,32 @@ default-language: Haskell2010 -- --------------------------------------------------------------------- + +Executable ga1 + Main-Is: GenApplicative/GA1.hs + Build-Depends: base >= 4.0 && < 5 + , parsec + default-language: Haskell2010 + +-- --------------------------------------------------------------------- + +Executable ga2 + Main-Is: GenApplicative/GA2.hs + Build-Depends: base >= 4.0 && < 5 + , parsec + default-language: Haskell2010 + +-- --------------------------------------------------------------------- + +Executable gaHTML + Main-Is: GenApplicative/HTMLTokenizer.hs + Build-Depends: base >= 4.0 && < 5 + , attoparsec + , conversion-text + , text + , conversion + , case-insensitive + , conversion-case-insensitive + , base-prelude + default-language: Haskell2010 +