HaRe-0.7.0.0: src/Language/Haskell/Refact/Utils.hs
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
module Language.Haskell.Refact.Utils
(
sameOccurrence
-- * Managing the GHC / project environment
, loadModuleGraphGhc
, getModuleGhc
, parseSourceFileGhc
, getModuleDetails
-- * The bits that do the work
, runRefacSession
, applyRefac
, refactDone
, ApplyRefacResult
, RefacSource(..)
, update
-- , writeRefactoredFiles
-- , Refact -- ^ deprecated
, fileNameToModName
, fileNameFromModSummary
, getModuleName
, clientModsAndFiles
, serverModsAndFiles
, getCurrentModuleGraph
, sortCurrentModuleGraph
-- * For testing
-- , initGhcSession
-- , prettyprint
, pwd
) where
import Control.Monad.State
import Data.List
import Data.Maybe
import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal
import Language.Haskell.Refact.Utils.GhcModuleGraph
import Language.Haskell.Refact.Utils.GhcUtils
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.TypeSyn
import Language.Haskell.Refact.Utils.TypeUtils
import System.Directory
-- import qualified Bag as GHC
-- import qualified BasicTypes as GHC
-- import qualified Coercion as GHC
import qualified Digraph as GHC
import qualified DynFlags as GHC
-- import qualified ErrUtils as GHC
import qualified FastString as GHC
-- import qualified ForeignCall as GHC
import qualified GHC
-- import qualified GHC as GHC
-- import qualified GHC.Paths as GHC
-- import qualified HsSyn as GHC
-- import qualified InstEnv as GHC
-- import qualified Module as GHC
-- import qualified MonadUtils as GHC
-- import qualified NameSet as GHC
-- import qualified OccName as GHC
import qualified Outputable as GHC
-- import qualified RdrName as GHC
-- import qualified SrcLoc as GHC
-- import qualified StaticFlags as GHC
-- import qualified TcEvidence as GHC
-- import qualified TcType as GHC
-- import qualified TypeRep as GHC
-- import qualified Var as GHC
import qualified Data.Generics as SYB
import qualified GHC.SYB.Utils as SYB
import Debug.Trace
-- ---------------------------------------------------------------------
-- Term defined in ../StrategyLib-4.0-beta/models/deriving/TermRep.hs
-- type PosToken = (Token, (Pos, String))
-- -- Defined at ../tools/base/parse2/Lexer/HsLayoutPre.hs:14:6
-- data Pos
-- = Pos {HsLexerPass1.char :: !Int, line :: !Int, column :: !Int}
-- -- Defined at ../tools/base/parse2/Lexer/HsLexerPos.hs:3:6
-- data Token
-- -- Defined at ../tools/base/parse2/Lexer/HsTokens.hs:5:6
-- GHC version
-- getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
-- getStartEndLoc ::
-- forall t.
-- (Term t, StartEndLoc t, Printable t) =>
-- [PosToken] -> t -> (SimpPos, SimpPos)
-- -- Defined at RefacLocUtils.hs:1188:1
-- type HsExpP = HsExpI PNT -- Defined at RefacTypeSyn.hs:17:6
-- data PNT = PNT PName (IdTy PId) OptSrcLoc
-- -- Defined at ../tools/base/defs/PNT.hs:23:6
-- ---------------------------------------------------------------------
pwd = getCurrentDirectory
-- ---------------------------------------------------------------------
-- | From file name to module name.
fileNameToModName :: FilePath -> RefactGhc GHC.ModuleName
fileNameToModName fileName = do
graph <- GHC.getModuleGraph
let mm = filter (\(mfn,_ms) -> mfn == Just fileName) $
map (\m -> (GHC.ml_hs_file $ GHC.ms_location m, m)) graph
case mm of
[] -> error $ "Can't find module name"
_ -> return $ GHC.moduleName $ GHC.ms_mod $ snd $ head mm
-- ---------------------------------------------------------------------
-- | Extract the module name from the parsed source, if there is one
getModuleName :: GHC.ParsedSource -> Maybe (GHC.ModuleName,String)
getModuleName (GHC.L _ modn) =
case (GHC.hsmodName modn) of
Nothing -> Nothing
Just (GHC.L _ modname) -> Just $ (modname,GHC.moduleNameString modname)
-- ---------------------------------------------------------------------
-- | Load a module graph into the GHC session, starting from main
loadModuleGraphGhc ::
Maybe FilePath -> RefactGhc ()
loadModuleGraphGhc maybeTargetFile = do
case maybeTargetFile of
Just targetFile -> do
-- Prefix with * to force interpretation, for inscopes
target <- GHC.guessTarget ("*" ++ targetFile) Nothing
GHC.setTargets [target]
GHC.load GHC.LoadAllTargets
return ()
Nothing -> return ()
return ()
-- ---------------------------------------------------------------------
-- | Once the module graph has been loaded, load the given module into
-- the RefactGhc monad
getModuleGhc ::
-- FilePath -> RefactGhc (ParseResult,[PosToken])
FilePath -> RefactGhc ()
getModuleGhc targetFile = do
graph <- GHC.getModuleGraph
let mm = filter (\(mfn,_ms) -> mfn == Just targetFile) $
map (\m -> (GHC.ml_hs_file $ GHC.ms_location m, m)) graph
case mm of
[(_,modSum)] -> getModuleDetails modSum
_ -> parseSourceFileGhc targetFile
-- ---------------------------------------------------------------------
-- | In the existing GHC session, put the requested TypeCheckedModule
-- into the RefactGhc monad
-- TODO: rename this function, it is not clear in a refactoring what
-- it does
getModuleDetails :: GHC.ModSummary -> RefactGhc ()
getModuleDetails modSum = do
p <- GHC.parseModule modSum
t <- GHC.typecheckModule p
-- GHC.setContext [GHC.IIModule (GHC.moduleName $ GHC.ms_mod modSum)]
setGhcContext modSum
tokens <- GHC.getRichTokenStream (GHC.ms_mod modSum)
mtm <- gets rsModule
case mtm of
Just tm -> if ((rsStreamModified tm == False)
&& ((GHC.mkFastString $ fileNameFromModSummary modSum) ==
(fileNameFromTok $ ghead "getModuleDetails" tokens)))
then return ()
else error "getModuleDetails: trying to load a module without finishing with active one"
Nothing -> putParsedModule t tokens
return ()
-- ---------------------------------------------------------------------
-- | Parse a single source file into a GHC session
parseSourceFileGhc ::
String -> RefactGhc ()
parseSourceFileGhc targetFile = do
target <- GHC.guessTarget ("*" ++ targetFile) Nothing -- The *
-- is to force interpretation, for inscopes
GHC.setTargets [target]
GHC.load GHC.LoadAllTargets -- Loads and compiles, much as calling ghc --make
graph <- GHC.getModuleGraph
let mm = filter (\(mfn,_ms) -> mfn == Just targetFile) $
map (\m -> (GHC.ml_hs_file $ GHC.ms_location m, m)) graph
-- let modSum = head g
let [(_,modSum)] = mm
getModuleDetails modSum
getExports (GHC.L _ hsmod) =
case hsmod of
GHC.HsModule _ (Just exports) _ _ _ _ -> exports
_ -> []
-- ---------------------------------------------------------------------
-- | The result of a refactoring is the file, a flag as to whether it
-- was modified, the updated token stream, and the updated AST
type ApplyRefacResult = ((FilePath, Bool), ([PosToken], GHC.RenamedSource))
-- | Manage a whole refactor session. Initialise the monad, load the
-- whole project if required, and then apply the individual
-- refactorings, and write out the resulting files.
--
-- It is intended that this forms the umbrella function, in which
-- applyRefac is called
--
{-
runRefacSessionOld :: Maybe RefactSettings
-> Maybe FilePath -- ^ main module for the project being refactored
-> RefactGhc [ApplyRefacResult] -- ^ The computation doing
-- the refactoriing
-> IO [FilePath]
runRefacSessionOld settings maybeMainFile comp = do
let
initialState = RefSt
{ rsSettings = fromMaybe defaultSettings settings
, rsUniqState = 1
, rsFlags = RefFlags False
, rsStorage = StorageNone
, rsModule = Nothing
}
(refactoredMods,_s) <- runRefactGhc (initGhcSession >>
loadModuleGraphGhc maybeMainFile >>
comp) initialState
let verbosity = rsetVerboseLevel (rsSettings initialState)
writeRefactoredFiles verbosity refactoredMods
return $ modifiedFiles refactoredMods
-}
-- -------------
runRefacSession :: RefactSettings
-> Cradle -- ^ Identifies the surrounding
-- project
-> RefactGhc [ApplyRefacResult] -- ^ The computation doing the
-- refactoring. Normally created
-- via 'applyRefac'
-> IO [FilePath]
runRefacSession settings cradle comp = do
let
initialState = RefSt
{ rsSettings = settings
, rsUniqState = 1
, rsFlags = RefFlags False
, rsStorage = StorageNone
, rsModule = Nothing
}
maybeMainFile = rsetMainFile settings
-- readLog <- initializeFlagsWithCradle opt cradle options True
-- setTargetFile fileName
(refactoredMods,_s) <- runRefactGhc (initGhcSession cradle (rsetImportPaths settings) >>
loadModuleGraphGhc maybeMainFile >>
comp) initialState
let verbosity = rsetVerboseLevel (rsSettings initialState)
writeRefactoredFiles verbosity refactoredMods
return $ modifiedFiles refactoredMods
-- ---------------------------------------------------------------------
data RefacSource = RSFile FilePath
| RSMod GHC.ModSummary
| RSAlreadyLoaded
-- 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
-> RefacSource -- ^ where to get the module and toks
-> RefactGhc (ApplyRefacResult,a)
applyRefac refac source = do
-- TODO: currently a temporary, poor man's surrounding state
-- management: store state now, set it to fresh, run refac, then
-- restore the state. Fix this to store the modules in some kind of cache.
fileName <- case source of
RSFile fname -> do getModuleGhc fname
return fname
RSMod ms -> do getModuleGhc $ fileNameFromModSummary ms
return $ fileNameFromModSummary ms
RSAlreadyLoaded -> do mfn <- getRefactFileName
case mfn of
Just fname -> return fname
Nothing -> error "applyRefac RSAlreadyLoaded: nothing loaded"
res <- refac -- Run the refactoring, updating the state as required
mod' <- getRefactRenamed
toks' <- fetchToksFinal
m <- getRefactStreamModified
-- Clear the refactoring state
clearParsedModule
return (((fileName,m),(toks', mod')),res)
-- ---------------------------------------------------------------------
-- |Returns True if any of the results has its modified flag set
refactDone :: [ApplyRefacResult] -> Bool
refactDone rs = any (\((_,d),_) -> d) rs
-- ---------------------------------------------------------------------
{-
applyRefacToClientMods refac fileName
= do clients <- clientModsAndFiles =<< fileNameToModName fileName
mapM (applyRefac refac Nothing) (map snd clients)
-}
-- ---------------------------------------------------------------------
modifiedFiles :: [((String, Bool), ([PosToken], GHC.RenamedSource))] -> [String]
modifiedFiles refactResult = map (\((s,_),_) -> s)
$ filter (\((_,b),_) -> b) refactResult
-- ---------------------------------------------------------------------
{- ++AZ++ TODO: replace this with a single function -}
{-
-- | Update the occurrence of one syntax phrase in a given scope by
-- another syntax phrase
updateR :: (SYB.Data t,SYB.Data t1, GHC.OutputableBndr t)
=> t -- ^ The syntax phrase to be updated.
-> t -- ^ The new syntax phrase.
-> t1 -- ^ The contex where the old syntax phrase occurs.
-> RefactGhc t1 -- ^ The result.
updateR old new t
= everywhereMStaged SYB.Renamer (SYB.mkM inExp) t
where
inExp :: GHC.Located t -> RefactGhc (GHC.Located t)
-- inExp (e::(GHC.OutputableBndr n, SYB.Data n) => GHC.Located n)
-- inExp (e@(GHC.L l _)::(GHC.OutputableBndr n, SYB.Data n) => GHC.Located n)
inExp (e@(GHC.L l _))
| sameOccurrence e old
= do (new', _) <- updateToks old new prettyprint
-- error "update: updated tokens" -- ++AZ++ debug
return new'
| otherwise = return e
-}
-- ---------------------------------------------------------------------
fileNameFromModSummary :: GHC.ModSummary -> FilePath
fileNameFromModSummary modSummary = fileName
where
-- TODO: what if we are loading a compiled only client and do not
-- have the original source?
Just fileName = GHC.ml_hs_file (GHC.ms_location modSummary)
-- ---------------------------------------------------------------------
class (SYB.Data t, SYB.Data t1) => Update t t1 where
-- | Update the occurrence of one syntax phrase in a given scope by
-- another syntax phrase of the same type
update:: t -- ^ The syntax phrase to be updated.
-> t -- ^ The new syntax phrase.
-> t1 -- ^ The contex where the old syntax phrase occurs.
-> RefactGhc t1 -- ^ The result.
instance (SYB.Data t, GHC.OutputableBndr n, SYB.Data n) => Update (GHC.Located (GHC.HsExpr n)) t where
update oldExp newExp t
= everywhereMStaged SYB.Parser (SYB.mkM inExp) t
where
inExp (e::GHC.Located (GHC.HsExpr n))
| sameOccurrence e oldExp
= do
drawTokenTree "update Located HsExpr starting" -- ++AZ++
_ <- updateToks oldExp newExp prettyprint False
drawTokenTree "update Located HsExpr done" -- ++AZ++
-- error "update: updated tokens" -- ++AZ++ debug
-- TODO: make sure to call syncAST
return newExp
| otherwise = return e
instance (SYB.Data t, GHC.OutputableBndr n, SYB.Data n) => Update (GHC.LPat n) t where
update oldPat newPat t
= everywhereMStaged SYB.Parser (SYB.mkM inPat) t
where
inPat (p::GHC.LPat n)
| sameOccurrence p oldPat
= do
_ <- updateToks oldPat newPat prettyprint False
-- TODO: make sure to call syncAST
return newPat
| otherwise = return p
instance (SYB.Data t, GHC.OutputableBndr n, SYB.Data n) => Update (GHC.LHsType n) t where
update oldTy newTy t
= everywhereMStaged SYB.Parser (SYB.mkM inTyp) t
where
inTyp (t::GHC.LHsType n)
| sameOccurrence t oldTy
= do
_ <- updateToks oldTy newTy prettyprint False
-- TODO: make sure to call syncAST
return newTy
| otherwise = return t
instance (SYB.Data t, GHC.OutputableBndr n1, GHC.OutputableBndr n2, SYB.Data n1, SYB.Data n2) => Update (GHC.LHsBindLR n1 n2) t where
update oldBind newBind t
= everywhereMStaged SYB.Parser (SYB.mkM inBind) t
where
inBind (t::GHC.LHsBindLR n1 n2)
| sameOccurrence t oldBind
= do
_ <- updateToks oldBind newBind prettyprint False
-- TODO: make sure to call syncAST
return newBind
| otherwise = return t
{- instance (SYB.Data t, GHC.OutputableBndr n, SYB.Data n) => Update [GHC.LPat n] t where
update oldPat newPat t
= everywhereMStaged SYB.Parser (SYB.mkM inPat) t
where
inPat (p::[GHC.LPat n])
| and $ zipWith sameOccurrence p oldPat
= do _ <- {- zipUpdateToks -} updateToks oldPat newPat prettyprint
return newPat
| otherwise = return p -}
{-
zipUpdateToks f [] [] c = return []
zipUpdateToks f [] _ _ = return []
zipUpdateToks f _ [] _ = return []
zipUpdateToks f (a:as) (b:bs) c = do res <- f a b c
rest <- zipUpdateToks f as bs c
return (res:rest)
-}
-- ---------------------------------------------------------------------
-- TODO: ++AZ++ get rid of the following instances, merge them into a
-- single function above
{-
instance (SYB.Data t) => Update (GHC.Located HsExpP) t where
update oldExp newExp t
= everywhereMStaged SYB.Parser (SYB.mkM inExp) t
where
inExp (e::GHC.Located HsExpP)
| sameOccurrence e oldExp
= do (newExp', _) <- updateToks oldExp newExp prettyprint
-- error "update: up`dated tokens" -- ++AZ++ debug
return newExp'
| otherwise = return e
-}
{- ++AZ++ comment out for now, see what breaks
instance (SYB.Data t) => Update (GHC.Located HsPatP) t where
update oldPat newPat t
= everywhereMStaged SYB.Parser (SYB.mkM inPat) t
where
inPat (p::GHC.Located HsPatP) -- = error "here"
| sameOccurrence p oldPat
= do (newPat', _) <- updateToksList [oldPat] newPat (prettyprintPatList prettyprint False)
return $ head newPat'
| otherwise = return p
instance (SYB.Data t) => Update [GHC.Located HsPatP] t where
update oldPat newPat t
= everywhereMStaged SYB.Parser (SYB.mkM inPat) t
where
inPat (p::[GHC.Located HsPatP])
| and $ zipWith sameOccurrence p oldPat
= do liftIO $ putStrLn (">" ++ SYB.showData SYB.Parser 0 p ++ "<")
(newPat', _) <- (updateToksList oldPat newPat (prettyprintPatList prettyprint False))
liftIO $ putStrLn (">" ++ SYB.showData SYB.Parser 0 newPat' ++ "<")
return newPat'
inPat p = return p
--++AZ++ comment out for now ends -}
-- ---------------------------------------------------------------------
getDynFlags :: IO GHC.DynFlags
getDynFlags = getDynamicFlags
{-
let
initialState = RefSt
{ rsSettings = RefSet [] Normal
, rsUniqState = 1
, rsFlags = RefFlags False
, rsStorage = StorageNone
, rsModule = Nothing
}
(df,_) <- runRefactGhc GHC.getSessionDynFlags initialState
return df
-}
-- ---------------------------------------------------------------------
-- | Write refactored program source to files.
{-
writeRefactoredFiles::Bool -- ^ True means the current refactoring is a sub-refactoring
->[((String,Bool),([PosToken],HsModuleP))]
-- ^ String: the file name; Bool: True means the file has
-- been modified.[PosToken]: the token stream; HsModuleP:
-- the module AST.
-> m ()
-}
-- writeRefactoredFiles (isSubRefactor::Bool) (files::[((String,Bool),([PosToken], HsModuleP))])
writeRefactoredFiles ::
VerboseLevel -> [((String, Bool), ([PosToken], GHC.RenamedSource))] -> IO ()
writeRefactoredFiles verbosity files
= do let filesModified = filter (\((_f,m),_) -> m == modified) files
-- TODO: restore the history function
-- ++AZ++ PFE0.addToHistory isSubRefactor (map (fst.fst) filesModified)
sequence_ (map modifyFile filesModified)
-- mapM_ writeTestDataForFile files -- This should be removed for the release version.
where
modifyFile ((fileName,_),(ts,renamed)) = do
-- let source = concatMap (snd.snd) ts
-- The bug fix only works if we strip any empty tokens
-- let ts' = bypassGHCBug7351 $ filter (\t -> not $ isEmpty t) ts
let ts' = bypassGHCBug7351 ts
let source = GHC.showRichTokenStream ts'
-- (Julien personnal remark) seq forces the evaluation of
-- its first argument and returns its second argument. It
-- is unclear for me why (length source) evaluation is
-- forced.
seq (length source) (writeFile (fileName ++ ".refactored") source)
when (verbosity == Debug) $
do
writeFile (fileName ++ ".tokens") (showToks ts')
writeFile (fileName ++ ".renamed_out") (showGhc renamed)
writeFile (fileName ++ ".AST_out") $ ((showGhc renamed) ++
"\n\n----------------------\n\n" ++
(SYB.showData SYB.Renamer 0 renamed))
-- http://hackage.haskell.org/trac/ghc/ticket/7351
bypassGHCBug7351 :: [PosToken] -> [PosToken]
bypassGHCBug7351 ts = map go ts
where
go :: (GHC.Located GHC.Token, String) -> (GHC.Located GHC.Token, String)
go rt@(GHC.L (GHC.UnhelpfulSpan _) _t,_s) = rt
go (GHC.L (GHC.RealSrcSpan l) t,s) = (GHC.L (fixCol l) t,s)
fixCol l = GHC.mkSrcSpan (GHC.mkSrcLoc (GHC.srcSpanFile l) (GHC.srcSpanStartLine l) ((GHC.srcSpanStartCol l) - 1))
(GHC.mkSrcLoc (GHC.srcSpanFile l) (GHC.srcSpanEndLine l) ((GHC.srcSpanEndCol l) - 1))
-- ---------------------------------------------------------------------
-- | Return the client modules and file names. The client modules of
-- module, say m, are those modules which directly or indirectly
-- import module m.
-- TODO: deal with an anonymous main module, by taking Maybe GHC.ModuleName
clientModsAndFiles
:: GHC.GhcMonad m => GHC.ModuleName -> m [GHC.ModSummary]
clientModsAndFiles m = do
ms <- GHC.getModuleGraph
modsum <- GHC.getModSummary m
let mg = getModulesAsGraph False ms Nothing
rg = GHC.transposeG mg
modNode = fromJust $ find (\(msum,_,_) -> mycomp msum modsum) (GHC.verticesG rg)
clientMods = filter (\msum -> not (mycomp msum modsum))
$ map summaryNodeSummary $ GHC.reachableG rg modNode
return clientMods
-- TODO : find decent name and place for this.
mycomp :: GHC.ModSummary -> GHC.ModSummary -> Bool
mycomp ms1 ms2 = (GHC.ms_mod ms1) == (GHC.ms_mod ms2)
-- ---------------------------------------------------------------------
-- | 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
serverModsAndFiles
:: GHC.GhcMonad m => GHC.ModuleName -> m [GHC.ModSummary]
serverModsAndFiles m = do
ms <- GHC.getModuleGraph
modsum <- GHC.getModSummary m
let mg = getModulesAsGraph False ms Nothing
modNode = fromJust $ find (\(msum,_,_) -> mycomp msum modsum) (GHC.verticesG mg)
serverMods = filter (\msum -> not (mycomp msum modsum))
$ map summaryNodeSummary $ GHC.reachableG mg modNode
return serverMods
-- ---------------------------------------------------------------------
instance (Show GHC.ModuleName) where
show = GHC.moduleNameString
-- ---------------------------------------------------------------------
-- | Return True if the given module name exists in the project.
--isAnExistingMod::( ) =>ModuleName->PFE0MT n i ds ext m Bool
{-
isAnExistingMod::(PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>
ModuleName->PFE0MT n i ds ext m Bool
isAnExistingMod m
= do ms<-allModules
return (elem m ms)
-}
-- ---------------------------------------------------------------------
-- | Get the current module graph, provided we are in a live GHC session
getCurrentModuleGraph :: RefactGhc GHC.ModuleGraph
getCurrentModuleGraph = GHC.getModuleGraph
sortCurrentModuleGraph :: RefactGhc [GHC.SCC GHC.ModSummary]
sortCurrentModuleGraph = do
-- g <- GHC.getModuleGraph
g <- getCurrentModuleGraph
let scc = GHC.topSortModuleGraph False g Nothing
return scc
-- getSubGraph optms = concat # getSortedSubGraph optms
-- getSortedSubGraph optms = flip optSubGraph optms # sortCurrentModuleGraph
-- allModules = moduleList # sortCurrentModuleGraph
-- moduleList g = [m|scc<-g,(_,(m,_))<-scc]