HaRe 0.7.1.3 → 0.7.1.4

raw patch · 15 files changed

+913/−1064 lines, 15 files

Files

• ChangeLog +3/−0
• HaRe.cabal +3/−4
• src/Language/Haskell/Refact/Case.hs +1/−1
• src/Language/Haskell/Refact/DupDef.hs +1/−1
• src/Language/Haskell/Refact/MoveDef.hs +1/−1
• src/Language/Haskell/Refact/Renaming.hs +1/−1
• src/Language/Haskell/Refact/SwapArgs.hs +1/−1
• src/Language/Haskell/Refact/Utils.hs +0/−590
• src/Language/Haskell/Refact/Utils/GhcBugWorkArounds.hs +1/−1
• src/Language/Haskell/Refact/Utils/Layout.hs +260/−289
• src/Language/Haskell/Refact/Utils/LayoutUtils.hs +0/−166
• src/Language/Haskell/Refact/Utils/Monad.hs +13/−4
• src/Language/Haskell/Refact/Utils/TokenUtils.hs +0/−1
• src/Language/Haskell/Refact/Utils/TypeUtils.hs +10/−4
• src/Language/Haskell/Refact/Utils/Utils.hs +618/−0

@@ -1,3 +1,6 @@+2014-03-09 v0.7.1.4+	* Load and process files using TH and/or QuasiQuotes+	* Make loading of multiple targets from a cabal file more robust 2014-03-06 v0.7.1.3 	* Various fixes for robustness based on real world trials 	* Rework the free and declared variable calculation to be more accurate

@@ -1,12 +1,12 @@ Name:                           HaRe-Version:                        0.7.1.3+Version:                        0.7.1.4 Author:                         Chris Brown, Huiqing Li, Simon Thompson, Alan Zimmerman Maintainer:                     Alan Zimmerman Stability:                      Alpha Bug-Reports:                    http://github.com/alanz/HaRe/issues License:                        BSD3 License-File:                   LICENSE-Homepage:                       http://www.cs.kent.ac.uk/projects/refactor-fp+Homepage:                       https://github.com/RefactoringTools/HaRe/wiki Description:    A Haskell 2010 refactoring tool. HaRe supports the full    Haskell 2010 standard, through making use of the GHC API.@@ -82,7 +82,6 @@            , Language.Haskell.Refact.MoveDef            , Language.Haskell.Refact.Renaming            , Language.Haskell.Refact.SwapArgs-           , Language.Haskell.Refact.Utils            , Language.Haskell.Refact.Utils.DualTree            , Language.Haskell.Refact.Utils.GhcBugWorkArounds            , Language.Haskell.Refact.Utils.GhcModuleGraph@@ -90,7 +89,6 @@            , Language.Haskell.Refact.Utils.GhcVersionSpecific            , Language.Haskell.Refact.Utils.Layout            , Language.Haskell.Refact.Utils.LayoutTypes-           , Language.Haskell.Refact.Utils.LayoutUtils            , Language.Haskell.Refact.Utils.LocUtils            , Language.Haskell.Refact.Utils.Monad            , Language.Haskell.Refact.Utils.MonadFunctions@@ -99,6 +97,7 @@            , Language.Haskell.Refact.Utils.TokenUtilsTypes            , Language.Haskell.Refact.Utils.TypeSyn            , Language.Haskell.Refact.Utils.TypeUtils+           , Language.Haskell.Refact.Utils.Utils            , Paths_HaRe         Extensions:      CPP 

@@ -8,7 +8,7 @@ import Control.Monad import Control.Monad.IO.Class import Language.Haskell.GhcMod-import Language.Haskell.Refact.Utils+import Language.Haskell.Refact.Utils.Utils import Language.Haskell.Refact.Utils.GhcUtils import Language.Haskell.Refact.Utils.LocUtils import Language.Haskell.Refact.Utils.Monad

@@ -12,7 +12,7 @@ import Data.Maybe  import Language.Haskell.GhcMod-import Language.Haskell.Refact.Utils+import Language.Haskell.Refact.Utils.Utils import Language.Haskell.Refact.Utils.GhcUtils import Language.Haskell.Refact.Utils.GhcVersionSpecific import Language.Haskell.Refact.Utils.LocUtils

@@ -24,7 +24,7 @@ import Data.Maybe  import Language.Haskell.GhcMod-import Language.Haskell.Refact.Utils+import Language.Haskell.Refact.Utils.Utils import Language.Haskell.Refact.Utils.GhcUtils import Language.Haskell.Refact.Utils.GhcVersionSpecific import Language.Haskell.Refact.Utils.LocUtils

@@ -13,7 +13,7 @@ import Exception  import Language.Haskell.GhcMod-import Language.Haskell.Refact.Utils+import Language.Haskell.Refact.Utils.Utils import Language.Haskell.Refact.Utils.GhcUtils import Language.Haskell.Refact.Utils.GhcVersionSpecific import Language.Haskell.Refact.Utils.LocUtils

@@ -15,7 +15,7 @@ -- import qualified OccName               as GHC  import Language.Haskell.GhcMod-import Language.Haskell.Refact.Utils+import Language.Haskell.Refact.Utils.Utils import Language.Haskell.Refact.Utils.GhcUtils import Language.Haskell.Refact.Utils.LocUtils import Language.Haskell.Refact.Utils.Monad

@@ -1,590 +0,0 @@-{-# 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-       , activateModule-       , 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-       -- , cd-       ) where--import Control.Monad.State-import Data.List-import Data.Maybe-import Language.Haskell.GhcMod-import Language.Haskell.Refact.Utils.DualTree-import Language.Haskell.Refact.Utils.GhcBugWorkArounds-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 System.FilePath.Posix--import qualified Digraph       as GHC-import qualified FastString    as GHC-import qualified GHC-import qualified Outputable    as GHC--import qualified Data.Generics as SYB-import qualified GHC.SYB.Utils as SYB---- import Debug.Trace---- ------------------------------------------------------------------------- | From file name to module name.-fileNameToModName :: FilePath -> RefactGhc GHC.ModuleName-fileNameToModName fileName = do-  mm <- getModuleMaybe fileName-  case mm of-    Nothing -> error $ "Can't find module name"-    Just ms ->  return $ GHC.moduleName $ GHC.ms_mod ms---- -----------------------------------------------------------------------getModuleMaybe :: FilePath -> RefactGhc (Maybe GHC.ModSummary)-getModuleMaybe fileName = do-  cfileName <- liftIO $ canonicalizePath fileName--  graphs <- gets rsGraph-  currentTgt <- gets rsCurrentTarget-  logm $ "getModuleMaybe " ++ show fileName ++ ":" ++ show (length graphs,currentTgt)--  let cgraph = concatMap (\(_,cg) -> cg) graphs-  -- graph <- GHC.getModuleGraph-  -- cgraph <- liftIO $ canonicalizeGraph graph--  let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph--  case mm of-    [] -> return Nothing-    _ -> return $ Just $ snd (ghead "getModuleMaybe" 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)---- ------------------------------------------------------------------------- | Once the module graph has been loaded, load the given module into--- the RefactGhc monad--- TODO: relax the equality test, if the file is loaded via cabal it--- may have a full filesystem path.-getModuleGhc ::-  FilePath -> RefactGhc ()-getModuleGhc targetFile = do-  -- TODO: consult cached store of multiple module graphs, one for-  --       each main file.-  mTarget <- identifyTargetModule targetFile-  case mTarget of-    Nothing -> return ()-    Just tm -> do-      void $ activateModule tm-      return ()--  mm <- getModuleMaybe targetFile-  case mm of-    Just ms -> getModuleDetails ms-    Nothing -> parseSourceFileGhc targetFile---- -----------------------------------------------------------------------identifyTargetModule :: FilePath -> RefactGhc (Maybe TargetModule)-identifyTargetModule targetFile = do-  currentDirectory <- liftIO getCurrentDirectory-  target1 <- liftIO $ canonicalizePath targetFile-  target2 <- liftIO $ canonicalizePath (combine currentDirectory targetFile)-  graphs <- gets rsModuleGraph--  let ff = catMaybes $ map (findInTarget target1 target2) graphs-  case ff of-    [] -> return Nothing-    ms -> return (Just (head ms))--findInTarget :: FilePath -> FilePath -> ([FilePath],GHC.ModuleGraph) -> Maybe TargetModule-findInTarget f1 f2 (fps,graph) = r-  where-    r = case filter (compModFiles f1 f2) graph of-          [] -> Nothing-          ms -> Just (fps,head ms)-    compModFiles :: FilePath-> FilePath -> GHC.ModSummary -> Bool-    compModFiles fileName1 fileName2 ms =-      case GHC.ml_hs_file $ GHC.ms_location ms of-        Nothing -> False-        Just fn -> fn == fileName1 || fn == fileName2---- ------------------------------------------------------------------------- | In the existing GHC session, put the requested TypeCheckedModule--- into the RefactGhc Monad, after ensuring that its originating--- target is the currently loaded one--activateModule :: TargetModule -> RefactGhc GHC.ModSummary-activateModule (target, modSum) = do-  logm $ "activateModule:" ++ show (target,GHC.ms_mod modSum)-  newModSum <- ensureTargetLoaded (target,modSum)-  getModuleDetails newModSum-  return newModSum---- ------------------------------------------------------------------------- | 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--      -- Use the workaround to get the tokens, the existing one does-      -- not return tokens for CPP processed files.-      -- tokens <- GHC.getRichTokenStream (GHC.ms_mod modSum)-      tokens <- getRichTokenStreamWA (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 :: FilePath -> RefactGhc ()-parseSourceFileGhc targetFile = do-     {--      target <- GHC.guessTarget ("*" ++ targetFile) Nothing -- The *-                                     -- is to force interpretation, for inscopes-      GHC.setTargets [target]-      void $ GHC.load GHC.LoadAllTargets -- Loads and compiles, much as calling ghc --make-     -}-      logm $ "parseSourceFileGhc:about to loadModuleGraphGhc for" ++ (show targetFile)-      loadModuleGraphGhc (Just [targetFile])-      logm $ "parseSourceFileGhc:loadModuleGraphGhc done"--      mm <- getModuleMaybe targetFile-      case mm of-        Nothing -> error $ "HaRe:unexpected error parsing " ++ targetFile-        Just modSum -> getModuleDetails modSum---- ------------------------------------------------------------------------- | 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), ([Ppr],[PosToken], GHC.RenamedSource))-type ApplyRefacResult = ((FilePath, Bool), ([Line],[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----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-        , rsGraph = []-        , rsModuleGraph = []-        , rsCurrentTarget = Nothing-        , rsModule = Nothing-        }--  (refactoredMods,_s) <- runRefactGhc (initGhcSession cradle (rsetImportPaths settings) >>-                                       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-    -- pprVal <- fetchPprFinal-    linesVal <- fetchLinesFinal-    m      <- getRefactStreamModified--    -- Clear the refactoring state-    clearParsedModule--    return (((fileName,m),(linesVal,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 :: [ApplyRefacResult] -> [String]-modifiedFiles refactResult = map (\((s,_),_) -> s)-                           $ filter (\((_,b),_) -> b) refactResult---- -----------------------------------------------------------------------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 -}---- ------------------------------------------------------------------------- | Write refactored program source to files.-writeRefactoredFiles ::-  VerboseLevel -> [ApplyRefacResult] -> 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,_),(finalLines,ts,renamed)) = do-           -- let source = concatMap (snd.snd) ts--           let ts' = bypassGHCBug7351 ts-           -- let source = GHC.showRichTokenStream ts'--           -- let source = renderPpr ppr-           let source = renderLines finalLines--           -- (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.-           let (baseFileName,ext) = splitExtension fileName-           seq (length source) (writeFile (baseFileName ++ ".refactored" ++ ext) 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))---- ------------------------------------------------------------------------- | 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.ModuleName -> RefactGhc [([FilePath],GHC.ModSummary)]-clientModsAndFiles m = do-  modsum <- GHC.getModSummary m--  -- ms' <- GHC.getModuleGraph-  ms' <- gets rsModuleGraph-  -- target <- gets rsCurrentTarget--  let getClients ms = clientMods-        where-          mg = getModulesAsGraph False ms Nothing-          rg = GHC.transposeG mg-          {--          modNode = gfromJust ("clientModsAndFiles:" ++ (showGhc (GHC.ms_mod modsum,target,mg))) -                  $ find (\(msum',_,_) -> mycomp msum' modsum) (GHC.verticesG rg)-          clientMods = filter (\msum' -> not (mycomp msum' modsum))-                     $ map summaryNodeSummary $ GHC.reachableG rg modNode-          -}-          maybeModNode = find (\(msum',_,_) -> mycomp msum' modsum) (GHC.verticesG rg)-          clientMods = case maybeModNode of-                         Nothing -> []-                         Just modNode ->-                           filter (\msum' -> not (mycomp msum' modsum))-                           $ map summaryNodeSummary $ GHC.reachableG rg modNode--  let clients = concatMap (\(f,mg) -> zip (repeat f) (getClients mg)) ms'-  -- Need to strip out duplicates, based on the snd of the tuple-      clients' = nubBy cc clients-      cc (_,mg1) (_,mg2)-        = if (show $ GHC.ms_mod mg1) == "Main" || (show $ GHC.ms_mod mg2) == "Main" -            then False-            else mycomp mg1 mg2--  logm $ "clientModsAndFiles:clients=" ++ show clients-  logm $ "clientModsAndFiles:clients'=" ++ show clients'-  return clients'---- 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--- TODO: make sure this works with multiple targets. Is that needed? No?-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 = gfromJust "serverModsAndFiles" $ 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---- -----------------------------------------------------------------------{- ++AZ++ what is using this?--- | 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 <- getCurrentModuleGraph-  let scc = GHC.topSortModuleGraph False g Nothing-  return scc---++AZ++ -}-

@@ -22,7 +22,7 @@  import Control.Exception import Data.IORef--- import Data.List.Utils+ import System.Directory import System.FilePath import qualified Data.Map as Map

@@ -253,8 +253,6 @@     (declLayout,tailToks) = foldl' doOne ([],toks) decls      r = strip $ declLayout ++ (makeLeafFromToks tailToks)-    -- r = error $ "allocDecls:tailToks=" ++ (show tailToks)-    -- r = error $ "allocDecls:declLayout=" ++ (show declLayout)      doOne :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])     doOne acc d@(GHC.L _ (GHC.TyClD       _)) = allocTyClD       acc d@@ -275,12 +273,154 @@ -- ---------------------------------------------------------------------  allocTyClD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])-allocTyClD (acc,toks) (GHC.L l (GHC.TyClD (GHC.ForeignType ln _))) = (r,toks')+allocTyClD (acc,toks) (GHC.L l (GHC.TyClD d)) = (r,toks')   where     (s1,clToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+    declLayout = allocLTyClDecl (GHC.L l d) clToks+    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ declLayout)]+allocTyClD _ x = error $ "allocTyClD:unexpected value:" ++ showGhc x++-- ---------------------------------------------------------------------++allocInstD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocInstD (acc,toks) (GHC.L l (GHC.InstD inst)) = (r,toks')+  where+    (s1,instToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+    instLayout = allocInstDecl (GHC.L l inst) instToks+    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ [makeGroup instLayout] )]+allocInstD _ x = error $ "allocInstD:unexpected value:" ++ showGhc x++-- ---------------------------------------------------------------------++allocDerivD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocDerivD (acc,toks) (GHC.L l (GHC.DerivD (GHC.DerivDecl typ))) = (r,toks')+  where+    (s1,bindToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+    typLayout = allocType typ bindToks+    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ [makeGroup typLayout] )]+allocDerivD _ x = error $ "allocDerivD:unexpected value:" ++ showGhc x++-- ---------------------------------------------------------------------++allocValD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocValD (acc,toks) (GHC.L l (GHC.ValD bind)) = (r,toks')+  where+    (s1,bindToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+    bindLayout = allocBind (GHC.L l bind) bindToks+    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ [makeGroup bindLayout] )]+allocValD _ x = error $ "allocValD:unexpected value:" ++ showGhc x++-- ---------------------------------------------------------------------++allocSigD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocSigD (acc,toks) (GHC.L l (GHC.SigD sig)) = (r,toks')+  where+    (s1,sigToks,toks')  = splitToksIncComments (ghcSpanStartEnd l) toks+    sigLayout = allocSig (GHC.L l sig) sigToks+    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)+                     ++ sigLayout)]+allocSigD _ x = error $ "allocSigD:unexpected value:" ++ showGhc x++-- ---------------------------------------------------------------------++allocDefD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocDefD (acc,toks) (GHC.L l (GHC.DefD (GHC.DefaultDecl typs))) = (r,toks')+  where+    (s1,typsToks,toks')  = splitToksIncComments (ghcSpanStartEnd l) toks+    typsLayout = allocList typs typsToks allocType+    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)+                     ++ typsLayout)]+allocDefD _ x = error $ "allocDefD:unexpected value:" ++ showGhc x++-- ---------------------------------------------------------------------++allocForD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocForD (acc,toks) (GHC.L l (GHC.ForD (GHC.ForeignImport (GHC.L ln _) typ@(GHC.L lt _) _coer _imp))) = (r,toks')+  where+    (s1,declToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+    (s2,nameToks,toks1) = splitToksIncComments (ghcSpanStartEnd ln) declToks+    (s3,typToks,toks2)  = splitToksIncComments (ghcSpanStartEnd lt) toks1+    nameLayout = [makeLeaf ln NoChange nameToks]+    typLayout = allocType typ typToks+    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)+                      ++ (makeLeafFromToks s2) ++ nameLayout+                      ++ (makeLeafFromToks s3) ++ typLayout+                      ++ (makeLeafFromToks toks2))]+allocForD (acc,toks) (GHC.L l (GHC.ForD (GHC.ForeignExport (GHC.L ln _) typ@(GHC.L lt _) _coer _imp))) = (r,toks')+  where+    (s1,declToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks+    (s2,nameToks,toks1) = splitToksIncComments (ghcSpanStartEnd ln) declToks+    (s3,typToks,toks2)  = splitToksIncComments (ghcSpanStartEnd lt) toks1+    nameLayout = [makeLeaf ln NoChange nameToks]+    typLayout = allocType typ typToks+    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)+                      ++ (makeLeafFromToks s2) ++ nameLayout+                      ++ (makeLeafFromToks s3) ++ typLayout+                      ++ (makeLeafFromToks toks2))]+allocForD _ x = error $ "allocForD:unexpected value:" ++ showGhc x++-- ---------------------------------------------------------------------++allocWarningD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocWarningD (acc,toks) (GHC.L _l (GHC.WarningD _)) = (acc,toks)+allocWarningD _ x = error $ "allocWarningD:unexpected value:" ++ showGhc x++-- ---------------------------------------------------------------------++allocAnnD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocAnnD (acc,toks) (GHC.L _l (GHC.AnnD _)) = (acc,toks)+allocAnnD _ x = error $ "allocAnnD:unexpected value:" ++ showGhc x++-- ---------------------------------------------------------------------++allocRuleD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocRuleD (acc,toks) (GHC.L _l (GHC.RuleD _)) = (acc,toks)+allocRuleD _ x = error $ "allocRuleD:unexpected value:" ++ showGhc x++-- ---------------------------------------------------------------------++allocVectD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocVectD (acc,toks) (GHC.L _l (GHC.VectD       _)) = (acc,toks)+allocVectD _ x = error $ "allocVectD:unexpected value:" ++ showGhc x++-- ---------------------------------------------------------------------++allocSpliceD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocSpliceD (acc,toks) (GHC.L l (GHC.SpliceD (GHC.SpliceDecl ex _))) = (r,toks')+  where+    (s1,exprToks,toks')  = splitToksIncComments (ghcSpanStartEnd l) toks+    exprLayout = allocExpr ex exprToks+    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)+                     ++ exprLayout)]+allocSpliceD _ x = error $ "allocSpliceD:unexpected value:" ++ showGhc x++-- ---------------------------------------------------------------------++allocDocD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+-- allocDocD (acc,toks) d@(GHC.L l (GHC.DocD        _))+--   = error "allocDocD undefined"+allocDocD _ x = error $ "allocDocD:unexpected value:" ++ showGhc x++-- ---------------------------------------------------------------------++allocQuasiQuoteD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])+allocQuasiQuoteD (acc,toks) (GHC.L l (GHC.QuasiQuoteD (GHC.HsQuasiQuote _n _ss _))) = (r,toks')+  where+    (s1,qqToks,toks')  = splitToksIncComments (ghcSpanStartEnd l) toks+    qqLayout = makeLeafFromToks qqToks+    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)+                     ++ qqLayout)]+allocQuasiQuoteD _ x = error $ "allocQuasiQuoteD:unexpected value:" ++ showGhc x++-- ---------------------------------------------------------------------++allocLTyClDecl :: GHC.LTyClDecl GHC.RdrName -> [PosToken] -> [LayoutTree]+allocLTyClDecl (GHC.L l (GHC.ForeignType ln _)) toks = r+  where+    (s1,clToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks     lnToks = allocLocated ln clToks-    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ lnToks)]-allocTyClD (acc,toks) (GHC.L l (GHC.TyClD (GHC.TyFamily _f n@(GHC.L ln _) vars _mk))) = (r,toks')+    r = [makeGroup (strip $ (makeLeafFromToks s1) ++ lnToks ++ (makeLeafFromToks toks'))]+allocLTyClDecl (GHC.L l (GHC.TyFamily _f n@(GHC.L ln _) vars _mk)) toks = r   where     (s1,clToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks     (s2,nToks,varsToks) = splitToksIncComments (ghcSpanStartEnd ln) toks'@@ -291,21 +431,24 @@     varsLayout = allocList vars varsToks allocTyVarBndr     s3 = [] #endif-    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks clToks)+    r = [makeGroup (strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks clToks)                      ++ (makeLeafFromToks s2) ++ nLayout ++ varsLayout-                     ++ (makeLeafFromToks s3))]+                     ++ (makeLeafFromToks s3)+                     ++ (makeLeafFromToks toks'))+        ] #if __GLASGOW_HASKELL__ > 704-allocTyClD (acc,toks) (GHC.L l (GHC.TyClD (GHC.TyDecl (GHC.L ln _) vars def _fvs))) = (r,toks')+allocLTyClDecl (GHC.L l (GHC.TyDecl (GHC.L ln _) vars def _fvs)) toks = r   where     (s1,clToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks     (s2,nToks,toks'') = splitToksIncComments (ghcSpanStartEnd ln) clToks     (varsLayout,toks3) = allocTyVarBndrs vars toks''     (typeLayout,toks4) = allocHsTyDefn def toks3-    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)+    r = [makeGroup (strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)                      ++ (makeLeafFromToks nToks) ++ varsLayout ++ typeLayout-                     ++ (makeLeafFromToks toks4))]+                     ++ (makeLeafFromToks toks4)+             ++ (makeLeafFromToks toks'))] #else-allocTyClD (acc,toks) (GHC.L l (GHC.TyClD (GHC.TyData _ (GHC.L lc ctx) (GHC.L ln _) vars mpats mkind cons mderivs))) = (r,toks')+allocLTyClDecl (GHC.L l (GHC.TyData _ (GHC.L lc ctx) (GHC.L ln _) vars mpats mkind cons mderivs)) toks = r   where     (s1,clToks,toks')    = splitToksIncComments (ghcSpanStartEnd l) toks     (s15,ctxToks,toks'a) = splitToksIncComments (ghcSpanStartEnd lc) clToks@@ -332,7 +475,7 @@           (s6,dToks,toks7') = splitToksForList derivs toks6           dLayout = [makeGroup (strip $ (makeLeafFromToks s6) ++ (allocList derivs dToks allocType))] -    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)+    r = [makeGroup (strip $ (makeLeafFromToks s1)                      ++ (makeLeafFromToks s15)                      ++ ctxLayout                      ++ (makeLeafFromToks s2)@@ -341,7 +484,9 @@                      ++ varsLayout ++ patsLayout                      ++ kindLayout                      ++ consLayout ++ derivsLayout-                     ++ (makeLeafFromToks toks7))]+                     ++ (makeLeafFromToks toks7)+                     ++ (makeLeafFromToks toks')+         )] {- tcdND :: NewOrData tcdCtxt :: LHsContext name@@ -386,9 +531,9 @@ -} #endif #if __GLASGOW_HASKELL__ > 704-allocTyClD (acc,toks) (GHC.L l (GHC.TyClD (GHC.ClassDecl (GHC.L lc ctx) n@(GHC.L ln _) vars fds sigs meths ats atdefs docs _fvs))) = (acc++r,toks')+allocLTyClDecl (GHC.L l (GHC.ClassDecl (GHC.L lc ctx) n@(GHC.L ln _) vars fds sigs meths ats atdefs docs _fvs)) toks = r #else-allocTyClD (acc,toks) (GHC.L l (GHC.TyClD (GHC.ClassDecl (GHC.L lc ctx) n@(GHC.L ln _) vars fds sigs meths ats atdefs docs     ))) = (acc++r,toks')+allocLTyClDecl (GHC.L l (GHC.ClassDecl (GHC.L lc ctx) n@(GHC.L ln _) vars fds sigs meths ats atdefs docs     )) toks = r #endif   where     (s1,clToks,  toks') = splitToksIncComments (ghcSpanStartEnd l) toks@@ -404,7 +549,8 @@      ctxLayout = allocHsContext ctx ctxToks     nLayout   = allocLocated n nToks-    fdsLayout = allocList fds fdToks allocFunDep+    -- fdsLayout = allocList fds fdToks allocFunDep+    fdsLayout = makeLeafFromToks fdToks      bindList = GHC.bagToList meths     sigMix     = makeMixedListEntry sigs     (shim allocSig)@@ -422,11 +568,13 @@     r = [makeGroup $ strip $ (makeLeafFromToks s1) ++ (makeLeafFromToks s2)              ++ ctxLayout ++ (makeLeafFromToks s3)              ++ nLayout ++ varsLayout ++ (makeLeafFromToks s5)-             ++ fdsLayout ++ bindsLayout]+             ++ fdsLayout ++ bindsLayout+             ++ (makeLeafFromToks toks')+        ]  #if __GLASGOW_HASKELL__ > 704 #else-allocTyClD (acc,toks) (GHC.L l (GHC.TyClD (GHC.TySynonym n@(GHC.L ln _) vars mpats synrhs@(GHC.L lr _)))) = (acc++r,toks')+allocLTyClDecl (GHC.L l (GHC.TySynonym n@(GHC.L ln _) vars mpats synrhs@(GHC.L lr _))) toks = r   where     (s1,clToks,toks')   = splitToksIncComments (ghcSpanStartEnd l) toks     (s2,nToks,toks2)    = splitToksIncComments (ghcSpanStartEnd ln) clToks@@ -446,176 +594,12 @@                      ++ varsLayout ++ patsLayout                      ++ (makeLeafFromToks s4)                      ++ synrhsLayout-                     ++ (makeLeafFromToks toks5))]+                     ++ (makeLeafFromToks toks5)+                     ++ (makeLeafFromToks toks')+         )] #endif -allocTyClD _ x = error $ "allocTyClD:unknown value:" ++ showGhc x--{--7.4.2-1) DualTree.layoutTreeToSourceTree retrieves the tokens in SourceTree format Move1--uncaught exception: ErrorCall (allocTyClD:unknown value:type Name = String)--TySynonym	 --  tcdLName :: Located name--      Name of the class- -      type constructor- -      Type constructor -  tcdTyVars :: [LHsTyVarBndr name]--      Class type variables--      type variables-  -      Type variables -  tcdTyPats :: Maybe [LHsType name]--    Type patterns See Note [tcdTyVars and tcdTyPats]--    Type patterns. See Note [tcdTyVars and tcdTyPats] -  tcdSynRhs :: LHsType name--    synonym expansion ---}---- -----------------------------------------------------------------------allocInstD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])-allocInstD (acc,toks) (GHC.L l (GHC.InstD inst)) = (r,toks')-  where-    (s1,instToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks-    instLayout = allocInstDecl (GHC.L l inst) instToks-    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ [makeGroup instLayout] )]-allocInstD _ x = error $ "allocInstD:unexpected value:" ++ showGhc x---- -----------------------------------------------------------------------allocDerivD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])-allocDerivD (acc,toks) (GHC.L l (GHC.DerivD (GHC.DerivDecl typ))) = (r,toks')-  where-    (s1,bindToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks-    typLayout = allocType typ bindToks-    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ [makeGroup typLayout] )]-allocDerivD _ x = error $ "allocDerivD:unexpected value:" ++ showGhc x---- -----------------------------------------------------------------------allocValD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])-allocValD (acc,toks) (GHC.L l (GHC.ValD bind)) = (r,toks')-  where-    (s1,bindToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks-    bindLayout = allocBind (GHC.L l bind) bindToks-    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1) ++ [makeGroup bindLayout] )]-    -- r = error $ "allocValD:bindToks=" ++ show bindToks-allocValD _ x = error $ "allocValD:unexpected value:" ++ showGhc x---- -----------------------------------------------------------------------allocSigD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])-allocSigD (acc,toks) (GHC.L l (GHC.SigD sig)) = (r,toks')-  where-    (s1,sigToks,toks')  = splitToksIncComments (ghcSpanStartEnd l) toks-    sigLayout = allocSig (GHC.L l sig) sigToks-    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)-                     ++ sigLayout)]-allocSigD _ x = error $ "allocSigD:unexpected value:" ++ showGhc x---- -----------------------------------------------------------------------allocDefD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])-allocDefD (acc,toks) (GHC.L l (GHC.DefD (GHC.DefaultDecl typs))) = (r,toks')-  where-    (s1,typsToks,toks')  = splitToksIncComments (ghcSpanStartEnd l) toks-    typsLayout = allocList typs typsToks allocType-    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)-                     ++ typsLayout)]-allocDefD _ x = error $ "allocDefD:unexpected value:" ++ showGhc x---- -----------------------------------------------------------------------allocForD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])-allocForD (acc,toks) (GHC.L l (GHC.ForD (GHC.ForeignImport (GHC.L ln _) typ@(GHC.L lt _) _coer _imp))) = (r,toks')-  where-    (s1,declToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks-    (s2,nameToks,toks1) = splitToksIncComments (ghcSpanStartEnd ln) declToks-    (s3,typToks,toks2)  = splitToksIncComments (ghcSpanStartEnd lt) toks1-    nameLayout = [makeLeaf ln NoChange nameToks]-    typLayout = allocType typ typToks-    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)-                      ++ (makeLeafFromToks s2) ++ nameLayout-                      ++ (makeLeafFromToks s3) ++ typLayout-                      ++ (makeLeafFromToks toks2))]-allocForD (acc,toks) (GHC.L l (GHC.ForD (GHC.ForeignExport (GHC.L ln _) typ@(GHC.L lt _) _coer _imp))) = (r,toks')-  where-    (s1,declToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks-    (s2,nameToks,toks1) = splitToksIncComments (ghcSpanStartEnd ln) declToks-    (s3,typToks,toks2)  = splitToksIncComments (ghcSpanStartEnd lt) toks1-    nameLayout = [makeLeaf ln NoChange nameToks]-    typLayout = allocType typ typToks-    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)-                      ++ (makeLeafFromToks s2) ++ nameLayout-                      ++ (makeLeafFromToks s3) ++ typLayout-                      ++ (makeLeafFromToks toks2))]-allocForD _ x = error $ "allocForD:unexpected value:" ++ showGhc x---- -----------------------------------------------------------------------allocWarningD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])-allocWarningD (acc,toks) (GHC.L _l (GHC.WarningD _)) = (acc,toks)-allocWarningD _ x = error $ "allocWarningD:unexpected value:" ++ showGhc x---- -----------------------------------------------------------------------allocAnnD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])-allocAnnD (acc,toks) (GHC.L _l (GHC.AnnD _)) = (acc,toks)-allocAnnD _ x = error $ "allocAnnD:unexpected value:" ++ showGhc x---- -----------------------------------------------------------------------allocRuleD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])-allocRuleD (acc,toks) (GHC.L _l (GHC.RuleD _)) = (acc,toks)-allocRuleD _ x = error $ "allocRuleD:unexpected value:" ++ showGhc x---- -----------------------------------------------------------------------allocVectD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])-allocVectD (acc,toks) (GHC.L _l (GHC.VectD       _)) = (acc,toks)-allocVectD _ x = error $ "allocVectD:unexpected value:" ++ showGhc x---- -----------------------------------------------------------------------allocSpliceD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])-allocSpliceD (acc,toks) (GHC.L l (GHC.SpliceD (GHC.SpliceDecl ex _))) = (r,toks')-  where-    (s1,exprToks,toks')  = splitToksIncComments (ghcSpanStartEnd l) toks-    exprLayout = allocExpr ex exprToks-    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)-                     ++ exprLayout)]-allocSpliceD _ x = error $ "allocSpliceD:unexpected value:" ++ showGhc x---- -----------------------------------------------------------------------allocDocD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])--- allocDocD (acc,toks) d@(GHC.L l (GHC.DocD        _))---   = error "allocDocD undefined"-allocDocD _ x = error $ "allocDocD:unexpected value:" ++ showGhc x---- -----------------------------------------------------------------------allocQuasiQuoteD :: ([LayoutTree],[PosToken]) -> GHC.LHsDecl GHC.RdrName -> ([LayoutTree],[PosToken])-allocQuasiQuoteD (acc,toks) (GHC.L l (GHC.QuasiQuoteD (GHC.HsQuasiQuote _n _ss _))) = (r,toks')-  where-    (s1,qqToks,toks')  = splitToksIncComments (ghcSpanStartEnd l) toks-    qqLayout = makeLeafFromToks qqToks-    r = acc ++ [makeGroup (strip $ (makeLeafFromToks s1)-                     ++ qqLayout)]-allocQuasiQuoteD _ x = error $ "allocQuasiQuoteD:unexpected value:" ++ showGhc x+allocLTyClDecl x _ = error $ "allocLTyClDecl:unknown value:" ++ showGhc x  -- --------------------------------------------------------------------- @@ -713,14 +697,58 @@                       ++ stmtLayout] -- ParStmt [([LStmt idL], [idR])] (SyntaxExpr idR) (SyntaxExpr idR) (SyntaxExpr idR) #endif-allocStmt (GHC.L _ (GHC.TransStmt _ _ _ _ _ _ _ _ )) toks = error "allocStmt TransStmt undefined"-allocStmt (GHC.L _ (GHC.RecStmt _ _ _ _ _ _ _ _ _))  toks = error "allocStmt RecStmt undefined"+allocStmt (GHC.L l (GHC.TransStmt _ stmts _ using@(GHC.L lu _) mby _ _ _ )) toks = r+  where+    (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks+    (s1,stmtsToks,toks1) = splitToksForList stmts toksExpr+    (s2,usingToks,toks2) = splitToksIncComments (ghcSpanStartEnd lu) toks1+    (byLayout,toks3) = case mby of+       Nothing -> ([],toks2)+       Just e -> (byL,toks3')+         where+           byL = allocExpr e toks2+           toks3' = [] +    stmtsLayout = allocList stmts stmtsToks allocStmt+    usingLayout = allocExpr using usingToks+    r = [makeGroup $ strip $ (makeLeafFromToks sb)+                  ++ (makeLeafFromToks s1) ++ stmtsLayout+                  ++ (makeLeafFromToks s2) ++ usingLayout+                  ++ byLayout+                  ++ (makeLeafFromToks toks3)+                  ++ (makeLeafFromToks sa)+        ]++allocStmt (GHC.L l (GHC.RecStmt stmts _ _ _ _ _ _ _ _))  toks = r+  where+    -- Note: everything after the first field is filled in from the+    -- renamer onwards, can be ignored here+    (sb,toksExpr,sa) = splitToksIncComments (ghcSpanStartEnd l) toks+    (s1,stmtsToks,toks1) = splitToksForList stmts toksExpr+    stmtsLayout = allocList stmts stmtsToks allocStmt++    r = [makeGroup $ strip $ (makeLeafFromToks sb)+                  ++ (makeLeafFromToks s1) ++ stmtsLayout+                  ++ (makeLeafFromToks toks1)+                  ++ (makeLeafFromToks sa)+        ]+{-+RecStmt+  recS_stmts :: [LStmtLR idL idR]+  recS_later_ids :: [idR]+  recS_rec_ids :: [idR]+  recS_bind_fn :: SyntaxExpr idR+  recS_ret_fn :: SyntaxExpr idR+  recS_mfix_fn :: SyntaxExpr idR+  recS_later_rets :: [PostTcExpr]+  recS_rec_rets :: [PostTcExpr]+  recS_ret_ty :: PostTcType+-} -- ---------------------------------------------------------------------  #if __GLASGOW_HASKELL__ > 704 allocParStmtBlock :: ([LayoutTree],[PosToken]) -> GHC.ParStmtBlock GHC.RdrName GHC.RdrName -> ([LayoutTree],[PosToken])-allocParStmtBlock (acc,toks) (GHC.ParStmtBlock stmts ns _) = (r,toks')+allocParStmtBlock (acc,toks) (GHC.ParStmtBlock stmts _ns _) = (acc ++ r,toks')   where     (s1,stmtToks,toks') = splitToksForList stmts toks     stmtLayout = allocList stmts stmtToks allocStmt@@ -928,7 +956,7 @@       GHC.ExpBr ex -> allocExpr ex toksBrack       GHC.PatBr p -> allocPat p toksBrack       GHC.DecBrL decs -> allocDecls decs toksBrack-      GHC.DecBrG g -> error $ "allocExpr.DecNrG undefined for " ++ (SYB.showData SYB.Parser 0 g)+      GHC.DecBrG g -> error $ "allocExpr.DecBrG undefined for " ++ (SYB.showData SYB.Parser 0 g)       GHC.TypBr typ -> allocType typ toksBrack       GHC.VarBr _ _ -> makeLeafFromToks toksBrack     r = [makeGroup $ strip $ (makeLeafFromToks sb)@@ -940,7 +968,8 @@ allocExpr e@(GHC.L _ (GHC.HsBracketOut _ _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0  e)  -allocExpr e@(GHC.L _ (GHC.HsSpliceE _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0  e)+allocExpr (GHC.L _l (GHC.HsSpliceE (GHC.HsSplice _ expr))) toks = allocExpr expr toks+ allocExpr e@(GHC.L _ (GHC.HsQuasiQuoteE _)) _ = error $ "allocExpr undefined for " ++ (SYB.showData SYB.Parser 0  e)  allocExpr (GHC.L l (GHC.HsProc p@(GHC.L lp _) cmd@(GHC.L lc _))) toks = r@@ -1062,6 +1091,8 @@       bs -> [placeAbove so p1 (rt,ct) bs]      r = strip $ (makeLeafFromToks (s1++doToks) ++ bindsLayout ++ makeLeafFromToks toks1)+allocDoExpr e _+  = error $ "Layout.allocDoExpr should not have been called with " ++ showGhc e  -- ------------------------------------- @@ -1071,7 +1102,8 @@     (s1,toksBinds,toks1) = splitToksIncComments (ghcSpanStartEnd l) toks     bindsLayout = allocList stmts toksBinds allocStmt     r = strip $ ((makeLeafFromToks s1) ++ bindsLayout ++ makeLeafFromToks toks1)-+allocExprListComp e _+  = error $ "Layout.allocExprListComp should not have been called with " ++ showGhc e  -- --------------------------------------------------------------------- @@ -1153,12 +1185,6 @@                (x:_) -> (tokenRow firstBindTok - tokenRow x,                          tokenCol firstBindTok - (tokenCol x + tokenLen x)) -    -- (rt,ct) = case (dropWhile isWhiteSpaceOrIgnored (reverse toksBinds)) of-    {--    (rt,ct) = case (dropWhile isEmpty (reverse toksBinds)) of-             [] -> (0,0)-             (x:_) -> (tokenRow x,tokenCol x)-     -}     (rt,ct) = calcLastTokenPos toksBinds      bindsLayout' = allocInterleavedLists bindList sigs (toksBinds) allocBind allocSig@@ -1170,9 +1196,15 @@       bs -> [placeAbove so p1 (rt,ct) bs]      r = strip $ (makeLeafFromToks s1) ++ bindsLayout ++ (makeLeafFromToks toks1)-    -- r = error $ "allocLocalBinds:(s1,toksBinds,toks1)=" ++ show (s1,toksBinds,toks1)+allocLocalBinds (GHC.HsValBinds (GHC.ValBindsOut _ _)) _+   = error "allocLocalBinds (GHC.HsValBinds (GHC.ValBindsOut..)) should not be required" -allocLocalBinds (GHC.HsIPBinds ib)  toks = error "allocLocalBinds undefined"+allocLocalBinds (GHC.HsIPBinds (GHC.IPBinds bs _))  toks = r+  where+    -- Note: only the Left x part is populated until after renaming, so no+    -- need to process deeper than this+    bindsLayout = allocList bs toks allocLocated+    r = strip $ bindsLayout  -- --------------------------------------------------------------------- @@ -1211,8 +1243,6 @@             (s2,matchToks,toks2') = splitToksForList matches toks1      r = strip $ [mkGroup l NoChange (strip $ nameLayout ++ matchesLayout)] ++ (makeLeafFromToks toks2)-    -- r = error $ "allocBind.FunBind:toks2=" ++ show toks2-    -- r = error $ "allocBind.FunBind:matchesLayout=" ++ show matchesLayout  allocBind (GHC.L l (GHC.PatBind lhs@(GHC.L ll _) grhs@(GHC.GRHSs rhs _) _ _ _)) toks = r   where@@ -1227,9 +1257,33 @@               ++ lhsLayout ++ (makeLeafFromToks s3) ++ grhsLayout               ++ (makeLeafFromToks toks')) ] -allocBind d@(GHC.L l (GHC.VarBind n rhs _)) toks  = error "allocValD:VarBinds"-allocBind d@(GHC.L l (GHC.AbsBinds tvs vars exps ev binds)) toks = error "allocValD:AbsBinds"+allocBind (GHC.L l (GHC.VarBind _n rhs@(GHC.L lr _) _)) toks  = r+  where+    (sb,toksBind,sa) = splitToksIncComments (ghcSpanStartEnd l) toks+    (s1,exprToks,toks2) = splitToksIncComments (ghcSpanStartEnd lr) toksBind+    exprLayout = allocExpr rhs exprToks+    r = [makeGroup $ (strip $ (makeLeafFromToks sb)+              ++ (makeLeafFromToks s1)+              ++ exprLayout+              ++ (makeLeafFromToks toks2)+              ++ (makeLeafFromToks sa)+             )+         ] +allocBind (GHC.L l (GHC.AbsBinds _tvs _vars _exps _ev binds)) toks = r+  where+    bindsList = GHC.bagToList binds+    (sb,toksBind,sa) = splitToksIncComments (ghcSpanStartEnd l) toks+    (s1,bindsToks,toks2) = splitToksForList bindsList toksBind+    bindsLayout = allocList bindsList bindsToks allocBind+    r = [makeGroup $ (strip $ (makeLeafFromToks sb)+              ++ (makeLeafFromToks s1)+              ++ bindsLayout+              ++ (makeLeafFromToks toks2)+              ++ (makeLeafFromToks sa)+             )+         ]+ -- ---------------------------------------------------------------------  allocSig :: GHC.LSig GHC.RdrName -> [PosToken] -> [LayoutTree]@@ -1292,11 +1346,6 @@  -- --------------------------------------------------------------------- -allocRecField :: GHC.HsRecFields GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> [PosToken] -> [LayoutTree]-allocRecField = error "Layout.allocRecField undefined"---- ---------------------------------------------------------------------- allocArithSeqInfo :: GHC.ArithSeqInfo GHC.RdrName -> [PosToken] -> [LayoutTree] allocArithSeqInfo (GHC.From e) toks = allocExpr e toks allocArithSeqInfo (GHC.FromThen e1@(GHC.L l _) e2) toksIn = r@@ -1470,7 +1519,6 @@ allocType n@(GHC.L _l (GHC.HsTyLit _) ) toks = allocLocated n toks #endif allocType (GHC.L l (GHC.HsWrapTy _ typ) ) toks = allocType (GHC.L l typ) toks--- allocType t toks = error $ "allocType: not implemented for:" ++ (showGhc t)  -- --------------------------------------------------------------------- @@ -1538,14 +1586,6 @@  -- --------------------------------------------------------------------- -allocLTyClDecl = error "allocLTyClDecl undefined"-allocFunDep = error "allocFunDep undefined"--allocHsTupArg :: GHC.HsTupArg GHC.RdrName -> [PosToken] -> [LayoutTree]-allocHsTupArg = error "allocHsTupArg undefined"---- ---------------------------------------------------------------------- allocTupArgList :: [GHC.HsTupArg GHC.RdrName] -> [PosToken] -> [LayoutTree] allocTupArgList tas toksIn = r   where@@ -1836,69 +1876,12 @@         (s1,funcToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks         funcLayout = allocFuncB x funcToks         r' = strip $ (makeLeafFromToks s1) ++ [makeGroup (strip funcLayout)]-        -- r' = error $ "allocB:(funcLayout)=" ++ show funcLayout      (layout,s2) = go ([],toksIn) axs bxs     r = strip $ layout ++ (makeLeafFromToks s2)  -- ----------------------------------------------------------------------{--allocInterleavedLists3 :: [GHC.Located a] -> [GHC.Located b] -> [GHC.Located c]-   -> [PosToken]-   -> (GHC.Located a -> [PosToken] -> [LayoutTree])-   -> (GHC.Located b -> [PosToken] -> [LayoutTree])-   -> (GHC.Located c -> [PosToken] -> [LayoutTree])-   -> [LayoutTree]-allocInterleavedLists3 axs bxs cxs toksIn allocFuncA allocFuncB allocFuncC = r-  where-    -- go :: ([LayoutTree],[PosToken]) -> [GHC.Located a] -> [GHC.Located b] -> ([LayoutTree],[PosToken])-    go (acc,ts) []     []    [] = (acc,ts)-    go (acc,ts) (a:as) []    [] = go (acc ++ aa,ts') as [] []-        where-          (aa,ts') = allocA a ts-    go (acc,ts) []     (b:bs) [] = go (acc ++ bb,ts') [] bs []-        where-          (bb,ts') = allocB b ts-    go (acc,ts) []     [] (c:cs) = go (acc ++ cc,ts') [] [] cs-        where-          (cc,ts') = allocC c ts -    go (acc,ts) (a:as) (b:bs) [] = if GHC.getLoc a < GHC.getLoc b-                             then go (acc ++ aa,tsa') as (b:bs) []-                             else go (acc ++ bb,tsb') (a:as) bs []-        where-          (aa,tsa') = allocA a ts-          (bb,tsb') = allocB b ts--    -- allocA :: GHC.Located a -> [PosToken] -> ([LayoutTree],[PosToken])-    allocA x@(GHC.L l _) toks = (r',toks')-      where-        (s1,funcToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks-        funcLayout = allocFuncA x funcToks-        r' = strip $ (makeLeafFromToks s1) ++ [makeGroup (strip funcLayout)]--    -- allocB :: GHC.Located b -> [PosToken] -> ([LayoutTree],[PosToken])-    allocB x@(GHC.L l _) toks = (r',toks')-      where-        (s1,funcToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks-        funcLayout = allocFuncB x funcToks-        r' = strip $ (makeLeafFromToks s1) ++ [makeGroup (strip funcLayout)]-        -- r' = error $ "allocB:(funcLayout)=" ++ show funcLayout--    -- allocC :: GHC.Located c -> [PosToken] -> ([LayoutTree],[PosToken])-    allocC x@(GHC.L l _) toks = (r',toks')-      where-        (s1,funcToks,toks') = splitToksIncComments (ghcSpanStartEnd l) toks-        funcLayout = allocFuncC x funcToks-        r' = strip $ (makeLeafFromToks s1) ++ [makeGroup (strip funcLayout)]-        -- r' = error $ "allocC:(funcLayout)=" ++ show funcLayout--    (layout,s2) = go ([],toksIn) axs bxs cxs-    r = strip $ layout ++ (makeLeafFromToks s2)--}---- ---------------------------------------------------------------------- shim ::     (GHC.Located a -> [PosToken] -> [LayoutTree])  -> (GHC.Located a -> [PosToken] -> ([LayoutTree],[PosToken]))@@ -1961,17 +1944,6 @@  -- --------------------------------------------------------------------- -{--placeOffset :: RowOffset -> ColOffset -> [LayoutTree] -> LayoutTree-placeOffset _ _ [] = error "placeOffset []"-placeOffset r c ls = Node (Entry loc (Offset r c) []) ls-  where-    loc = combineSpans (getLoc $ head ls) (getLoc $ last ls)--}----- ---------------------------------------------------------------------- makeGroup :: [LayoutTree] -> LayoutTree makeGroup [x] = x makeGroup ls  = makeGroupLayout NoChange ls@@ -1992,15 +1964,14 @@ makeLeafFromToks [] = [] makeLeafFromToks toks = [Node (Entry loc NoChange toks) []]   where-    -- TODO: ignore leading/trailing comments etc-    -- loc = combineSpans (sf $ tokenSrcSpan $ head toks) (sf $ tokenSrcSpan $ last toks)-     loc = sspan      (startLoc',endLoc') = nonCommentSpanLayout toks     sspan    = if (startLoc',endLoc') == ((0,0),(0,0))       then error $ "mkLeafFromToks:null span for:" ++ (show toks)       else simpPosToForestSpan (startLoc',endLoc')++-- ---------------------------------------------------------------------  -- |Extract the start and end position of a span, without any leading -- or trailing comments

@@ -1,166 +0,0 @@-{-# LANGUAGE TypeOperators #-}--module Language.Haskell.Refact.Utils.LayoutUtils-  (-  --   getLayoutFor-  -- , addDeclLayoutAfterSrcSpan-   showLTOne-  -- , openZipper-  ) where--import qualified GHC           as GHC--import qualified Data.Generics as SYB-import qualified GHC.SYB.Utils as SYB--import Language.Haskell.Refact.Utils.GhcVersionSpecific-import Language.Haskell.Refact.Utils.Layout-import Language.Haskell.Refact.Utils.LayoutTypes-import Language.Haskell.Refact.Utils.LocUtils-import Language.Haskell.Refact.Utils.Monad-import Language.Haskell.Refact.Utils.TokenUtils-import Language.Haskell.Refact.Utils.TokenUtilsTypes-import Language.Haskell.Refact.Utils.TypeSyn--import Data.Tree--import qualified Data.Tree.Zipper as Z--import qualified Language.Haskell.Refact.Utils.TokenUtils      as U-import qualified Language.Haskell.Refact.Utils.TokenUtilsTypes as U---- -----------------------------------------------------------------------getLayoutFor :: GHC.SrcSpan -> TokenLayout -> LayoutTree-getLayoutFor sspan (TL layout) = getLayoutFor' sspan layout--getLayoutFor' :: GHC.SrcSpan -> LayoutTree -> LayoutTree--- getLayoutFor' sspan tl@(Leaf ss _ _)-getLayoutFor' sspan tl@(Node (U.Entry ss _ _) [])-  | sspan == (fs ss) = tl-  | otherwise = error $ "getLayoutFor :" ++ (showGhc sspan) ++ " not in " ++ (showGhc tl)---- getLayoutFor' sspan tl@(Group ss _ subs)-getLayoutFor' sspan tl@(Node (U.Entry ss _ []) subs)-  | sspan == (fs ss) = tl-  | null subs        = error $ "getLayoutFor :" ++ (showGhc sspan) ++ " not in " ++ (showGhc tl)-  | length subs > 1  = error $ "getLayoutFor :" ++ (showGhc sspan) ++ " multiple in " ++ (showGhc tl)-  | otherwise = getLayoutFor' sspan sub-  where-    sub = getChildForSpan sspan subs---- -----------------------------------------------------------------------{--addDeclLayoutAfterSrcSpan :: (SYB.Data t) =>-     LayoutTree  -- ^TokenTree to be modified-  -> GHC.SrcSpan -- ^Preceding location for new tokens-  -> U.Positioning-  -> LayoutTree -- ^New tokens to be added-  -> GHC.Located t  -- ^Declaration the tokens belong to, to be synced-  -> (TokenLayout, GHC.SrcSpan,GHC.Located t) -- ^ updated TokenTree ,SrcSpan location for-                               -- the new tokens in the TokenTree, and-                               -- updated AST element-addDeclLayoutAfterSrcSpan tl oldSpan pos layout t = (tl'',newSpan,t')-  where-    (tl',newSpan) = addLayoutAfterSrcSpan tl oldSpan pos layout-    (t',tl'') = syncAST t newSpan tl'--}---- ----------------------------------------------------------------------{---- |Add new tokens after the given SrcSpan, constructing a new SrcSpan--- in the process-addLayoutAfterSrcSpan ::-  LayoutTree  -- ^TokenTree to be modified-  -> GHC.SrcSpan -- ^Preceding location for new tokens-  -> U.Positioning-  -> LayoutTree -- ^New tokens to be added-  -> (LayoutTree, GHC.SrcSpan) -- ^ updated TokenTree and SrcSpan location for-                               -- the new tokens in the TokenTree-addLayoutAfterSrcSpan lt oldSpan pos layout = (lt',newSpan')-  where-    tree = getSrcSpanFor lt oldSpan--    toks'' = placeLayoutForSpan lt oldSpan tree pos layout--    (startPos,endPos) = U.nonCommentSpan toks''--    newSpan = U.posToSrcSpanTok mkZeroToken (startPos,endPos)--    (lt',newSpan') = addNewSrcSpanAndToksAfter lt oldSpan newSpan pos layout--}--- ------------------------------------------------------------------------- getSrcSpanFor = error "getSrcSpanFor undefined"--- placeLayoutForSpan = undefined--- addNewSrcSpanAndToksAfter = undefined---- -----------------------------------------------------------------------{--openZipperToSpan :: GHC.SrcSpan -> LayoutTree -> Top :>> LayoutTree-openZipperToSpan sspan lay = r-  where-    -- r = toZipper lay-    r = zipper lay--}-{--openZipper :: GHC.SrcSpan -> Top :>> LayoutTree -> Top :>> LayoutTree-openZipper sspan z-  | getLoc (view focus z) == sspan = z-  | isLeaf (view focus z) = error $ "openZipperToSpan not found " ++ showGhc sspan ++ ":" ++ showLTOne (view focus z)-  | otherwise = openZipper sspan z'-  where-    (Group _ _ subs) = view focus z-    z' = zipper (getChildForSpan sspan subs)--}-{--openZipper :: GHC.SrcSpan-     -> Z.TreePos Z.Full Label-     -> Z.TreePos Z.Full Label-openZipper sspan z-  | getLoc (Z.tree z) == sspan = z-  | otherwise = openZipper sspan child-  where-    child = ghead "openZipper" $ filter (GHC.isSubspanOf sspan . getLoc . Z.tree) childrenAsZ-    childrenAsZ = getChildrenAsZ z--}--- ----------------------------------------------------------------------{--getChildrenAsZ :: Z.TreePos Z.Full a -> [Z.TreePos Z.Full a]-getChildrenAsZ z = go [] (Z.firstChild z)-  where-    go acc Nothing = acc-    go acc (Just zz) = go (acc ++ [zz]) (Z.next zz)--}---- ------------------------------------------------------------------------- TODO: need to make ForestLine version of isSubspanof-getChildForSpan :: GHC.SrcSpan -> [LayoutTree] -> LayoutTree-getChildForSpan sspan subs = sub-  where-    sub = ghead "getChildForSpan" $ map snd $ filter (GHC.isSubspanOf sspan . fst) -                                  $ map (\t -> (fs $ getLoc t,t)) subs---- -----------------------------------------------------------------------showLTOne :: LayoutTree -> String--- showLTOne (Leaf ss lay _toks) = "(Leaf "  ++ (showGhc ss) ++ " " ++ (show lay) ++ " " ++ "toks)"--- showLTOne (Group ss lay subs) = "(Group " ++ (showGhc ss) ++ " " ++ (show lay) ++ " " ++ showGhc (map getLoc subs) ++ ")"-showLTOne (Node (U.Entry ss lay _toks) []) = "(Leaf "  ++ (showGhc ss) ++ " " ++ (show lay) ++ " " ++ "toks)"-showLTOne (Node (U.Entry ss lay []) subs) = "(Group " ++ (showGhc ss) ++ " " ++ (show lay) ++ " " ++ showGhc (map getLoc subs) ++ ")"----- -----------------------------------------------------------------------isLeaf :: LayoutTree -> Bool-isLeaf (Node _ []) = True-isLeaf _            = False---- ------------------------------------------------------------------------- experiments--

@@ -39,11 +39,9 @@ import Control.Monad.State import Data.List import Data.Time.Clock--- import Data.Tree import Exception import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Internal--- import Language.Haskell.Refact.Utils.GhcVersionSpecific import Language.Haskell.Refact.Utils.TokenUtilsTypes import Language.Haskell.Refact.Utils.TypeSyn import System.Directory@@ -268,9 +266,18 @@       graph <- GHC.getModuleGraph       cgraph <- liftIO $ canonicalizeGraph graph +      let canonMaybe filepath = ghandle handler (canonicalizePath filepath)+            where+              handler :: SomeException -> IO FilePath+              handler _e = return filepath++      ctargetFiles <- liftIO $ mapM canonMaybe targetFiles+       settings <- get-      put $ settings { rsGraph = (rsGraph settings) ++ [(targetFiles,cgraph)]-                     , rsModuleGraph = (rsModuleGraph settings) ++ [(targetFiles,graph)]+      put $ settings { -- rsGraph = (rsGraph settings) ++ [(targetFiles,cgraph)]+                       rsGraph = (rsGraph settings) ++ [(ctargetFiles,cgraph)]+                     -- , rsModuleGraph = (rsModuleGraph settings) ++ [(targetFiles,graph)]+                     , rsModuleGraph = (rsModuleGraph settings) ++ [(ctargetFiles,graph)]                      , rsCurrentTarget = maybeTargetFiles                      } @@ -286,6 +293,7 @@ loadTarget :: [FilePath] -> RefactGhc () loadTarget targetFiles = do       setTargetFiles targetFiles+      checkSlowAndSet       void $ GHC.load GHC.LoadAllTargets  -- ---------------------------------------------------------------------@@ -300,6 +308,7 @@   if currentTarget == Just target     then return modSum     else do+      logm $ "ensureTargetLoaded: loading:" ++ show target       loadTarget target       put $ settings { rsCurrentTarget = Just target}       graph <- GHC.getModuleGraph

@@ -154,7 +154,6 @@ import Language.Haskell.Refact.Utils.TokenUtilsTypes import Language.Haskell.Refact.Utils.TypeSyn --- import Control.Monad.Trans.State.Lazy import Data.Bits import Data.List import Data.Tree

@@ -1023,13 +1023,13 @@     pat (GHC.NPlusKPat (GHC.L _ n) _ _ _) = return (FN [],DN [n])     pat _p@(GHC.SigPatIn (GHC.L _ p) b) = do       fdp <- pat p-      (FN fb,DN db) <- hsFreeAndDeclaredGhc b+      (FN fb,DN _db) <- hsFreeAndDeclaredGhc b       -- logm $ "hsFreeAndDeclaredGhc.pat.SigPatIn:p=" ++ showGhc _p       -- logm $ "hsFreeAndDeclaredGhc.pat.SigPatIn:(fdp,(FN fb,DN db))=" ++ show (fdp,(FN fb,DN db)) #if __GLASGOW_HASKELL__ > 704       return $ fdp <> (FN fb,DN []) #else-      return $ fdp <> (FN db,DN [])+      return $ fdp <> (FN _db,DN []) #endif     pat (GHC.SigPatOut (GHC.L _ p) _) = pat p     pat (GHC.CoPat _ p _) = pat p@@ -1348,8 +1348,14 @@ #else     lstmt (GHC.L _ (GHC.ParStmt ps _ _ _)) = hsFreeAndDeclaredGhc ps #endif-    -- TransStmt-    -- RecStmt+    lstmt (GHC.L _ (GHC.TransStmt _ stmts _ using mby _ _ _)) = do+      fds <- hsFreeAndDeclaredGhc stmts+      fdu <- hsFreeAndDeclaredGhc using+      fdb <- case mby of+        Nothing -> return emptyFD+        Just e -> hsFreeAndDeclaredGhc e+      return $ fds <> fdu <> fdb+    lstmt (GHC.L _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _)) = hsFreeAndDeclaredGhc stmts      -- ----------------------- 

@@ -0,0 +1,618 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}++module Language.Haskell.Refact.Utils.Utils+       (+         sameOccurrence++       -- * Managing the GHC / project environment+       -- , loadModuleGraphGhc+       , getModuleGhc+       , parseSourceFileGhc+       , activateModule+       , 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+       -- , cd+       ) where++import Control.Monad.State+import Data.List+import Data.Maybe+import Data.Monoid+import Language.Haskell.GhcMod+import Language.Haskell.Refact.Utils.DualTree+import Language.Haskell.Refact.Utils.GhcBugWorkArounds+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 System.FilePath.Posix++import qualified Digraph       as GHC+import qualified FastString    as GHC+import qualified GHC+import qualified Outputable    as GHC++import qualified Data.Generics as SYB+import qualified GHC.SYB.Utils as SYB++-- import Debug.Trace++-- ---------------------------------------------------------------------++-- | From file name to module name.+fileNameToModName :: FilePath -> RefactGhc GHC.ModuleName+fileNameToModName fileName = do+  mm <- getModuleMaybe fileName+  case mm of+    Nothing -> error $ "Can't find module name"+    Just ms ->  return $ GHC.moduleName $ GHC.ms_mod ms++-- ---------------------------------------------------------------------++getModuleMaybe :: FilePath -> RefactGhc (Maybe GHC.ModSummary)+getModuleMaybe fileName = do+  cfileName <- liftIO $ canonicalizePath fileName+  -- logm $ "getModuleMaybe for (fileName,cfileName):" ++ show (fileName,cfileName)++  graphs <- gets rsGraph+  currentTgt <- gets rsCurrentTarget+  logm $ "getModuleMaybe " ++ show fileName ++ ":" ++ show (length graphs,currentTgt)++  let cgraph = concatMap (\(_,cg) -> cg) graphs+  -- graph <- GHC.getModuleGraph+  -- cgraph <- liftIO $ canonicalizeGraph graph++  -- logm $ "getModuleMaybe: [mfn]=" ++ show (map (\(mfn,_ms) -> mfn) cgraph)++  let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph+  -- logm $ "getModuleMaybe: mm=" ++ show mm++  case mm of+    [] -> return Nothing+    _ -> do+      let (mfn,ms) = (ghead "getModuleMaybe" mm)+      -- activateModule (fromJust mfn,ms)+      return $ Just ms++-- ---------------------------------------------------------------------++-- | 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)++-- ---------------------------------------------------------------------++-- | Once the module graph has been loaded, load the given module into+-- the RefactGhc monad+-- TODO: relax the equality test, if the file is loaded via cabal it+-- may have a full filesystem path.+getModuleGhc ::+  FilePath -> RefactGhc ()+getModuleGhc targetFile = do+  -- TODO: consult cached store of multiple module graphs, one for+  --       each main file.+  mTarget <- identifyTargetModule targetFile+  case mTarget of+    Nothing -> return ()+    Just tm -> do+      void $ activateModule tm+      return ()++  mm <- getModuleMaybe targetFile+  case mm of+    Just ms -> getModuleDetails ms+    Nothing -> parseSourceFileGhc targetFile++-- ---------------------------------------------------------------------++identifyTargetModule :: FilePath -> RefactGhc (Maybe TargetModule)+identifyTargetModule targetFile = do+  currentDirectory <- liftIO getCurrentDirectory+  target1 <- liftIO $ canonicalizePath targetFile+  target2 <- liftIO $ canonicalizePath (combine currentDirectory targetFile)+  -- logm $ "identifyTargetModule:(targetFile,target1,target2)=" ++ show (targetFile,target1,target2)+  graphs <- gets rsModuleGraph++  -- logm $ "identifyTargetModule:graphs=" ++ show graphs++  let ff = catMaybes $ map (findInTarget target1 target2) graphs+  -- logm $ "identifyTargetModule:ff=" ++ show ff+  case ff of+    [] -> return Nothing+    ms -> return (Just (ghead ("identifyTargetModule:" ++ (show ms)) ms))++findInTarget :: FilePath -> FilePath -> ([FilePath],GHC.ModuleGraph) -> Maybe TargetModule+findInTarget f1 f2 (fps,graph) = r'+  where+    -- We also need to process the case where it is a main file for an exe.+    re :: Maybe TargetModule+    re = case fps of+      [x] -> re' -- single target, could be an exe+       where+         re' = case filter isMainModSummary graph of+           [] -> Nothing+           ms -> if x == f1 || x == f2 then Just (fps,ghead "findInTarget" ms)+                                      else Nothing+      _  -> Nothing+    isMainModSummary ms = (show $ GHC.ms_mod ms) == "Main"++    r = case filter (compModFiles f1 f2) graph of+          [] -> Nothing+          ms -> Just (fps,ghead "findInTarget.2" ms)+    compModFiles :: FilePath-> FilePath -> GHC.ModSummary -> Bool+    compModFiles fileName1 fileName2 ms =+      case GHC.ml_hs_file $ GHC.ms_location ms of+        Nothing -> False+        Just fn -> fn == fileName1 || fn == fileName2++    r' = listToMaybe $ catMaybes [r,re]++-- ---------------------------------------------------------------------++-- | In the existing GHC session, put the requested TypeCheckedModule+-- into the RefactGhc Monad, after ensuring that its originating+-- target is the currently loaded one++activateModule :: TargetModule -> RefactGhc GHC.ModSummary+activateModule (target, modSum) = do+  logm $ "activateModule:" ++ show (target,GHC.ms_mod modSum)+  newModSum <- ensureTargetLoaded (target,modSum)+  getModuleDetails newModSum+  return newModSum++-- ---------------------------------------------------------------------++-- | 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++      -- Use the workaround to get the tokens, the existing one does+      -- not return tokens for CPP processed files.+      -- tokens <- GHC.getRichTokenStream (GHC.ms_mod modSum)+      tokens <- getRichTokenStreamWA (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 if rsStreamModified tm == False+                            then putParsedModule t tokens+                            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 :: FilePath -> RefactGhc ()+parseSourceFileGhc targetFile = do+     {-+      target <- GHC.guessTarget ("*" ++ targetFile) Nothing -- The *+                                     -- is to force interpretation, for inscopes+      GHC.setTargets [target]+      void $ GHC.load GHC.LoadAllTargets -- Loads and compiles, much as calling ghc --make+     -}+      -- logm $ "parseSourceFileGhc:about to loadModuleGraphGhc for" ++ (show targetFile)+      loadModuleGraphGhc (Just [targetFile])+      -- logm $ "parseSourceFileGhc:loadModuleGraphGhc done"++      mm <- getModuleMaybe targetFile+      case mm of+        Nothing -> error $ "HaRe:unexpected error parsing " ++ targetFile+        Just modSum -> getModuleDetails modSum++-- ---------------------------------------------------------------------++-- | 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), ([Ppr],[PosToken], GHC.RenamedSource))+type ApplyRefacResult = ((FilePath, Bool), ([Line],[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+--+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+        , rsGraph = []+        , rsModuleGraph = []+        , rsCurrentTarget = Nothing+        , rsModule = Nothing+        }++  (refactoredMods,_s) <- runRefactGhc (initGhcSession cradle (rsetImportPaths settings) >>+                                       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+    -- pprVal <- fetchPprFinal+    linesVal <- fetchLinesFinal+    m      <- getRefactStreamModified++    -- Clear the refactoring state+    clearParsedModule++    return (((fileName,m),(linesVal,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 :: [ApplyRefacResult] -> [String]+modifiedFiles refactResult = map (\((s,_),_) -> s)+                           $ filter (\((_,b),_) -> b) refactResult++-- ---------------------------------------------------------------------++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 -}++-- ---------------------------------------------------------------------++-- | Write refactored program source to files.+writeRefactoredFiles ::+  VerboseLevel -> [ApplyRefacResult] -> 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,_),(finalLines,ts,renamed)) = do+           -- let source = concatMap (snd.snd) ts++           let ts' = bypassGHCBug7351 ts+           -- let source = GHC.showRichTokenStream ts'++           -- let source = renderPpr ppr+           let source = renderLines finalLines++           -- (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.+           let (baseFileName,ext) = splitExtension fileName+           seq (length source) (writeFile (baseFileName ++ ".refactored" ++ ext) 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))++-- ---------------------------------------------------------------------++-- | 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.ModuleName -> RefactGhc [([FilePath],GHC.ModSummary)]+clientModsAndFiles m = do+  modsum <- GHC.getModSummary m++  -- ms' <- GHC.getModuleGraph+  ms' <- gets rsModuleGraph+  -- target <- gets rsCurrentTarget++  let getClients ms = clientMods+        where+          mg = getModulesAsGraph False ms Nothing+          rg = GHC.transposeG mg+          {-+          modNode = gfromJust ("clientModsAndFiles:" ++ (showGhc (GHC.ms_mod modsum,target,mg))) +                  $ find (\(msum',_,_) -> mycomp msum' modsum) (GHC.verticesG rg)+          clientMods = filter (\msum' -> not (mycomp msum' modsum))+                     $ map summaryNodeSummary $ GHC.reachableG rg modNode+          -}+          maybeModNode = find (\(msum',_,_) -> mycomp msum' modsum) (GHC.verticesG rg)+          clientMods = case maybeModNode of+                         Nothing -> []+                         Just modNode ->+                           filter (\msum' -> not (mycomp msum' modsum))+                           $ map summaryNodeSummary $ GHC.reachableG rg modNode++  let clients = concatMap (\(f,mg) -> zip (repeat f) (getClients mg)) ms'+  -- Need to strip out duplicates, based on the snd of the tuple+      clients' = nubBy cc clients+      cc (_,mg1) (_,mg2)+        = if (show $ GHC.ms_mod mg1) == "Main" || (show $ GHC.ms_mod mg2) == "Main" +            then False+            else mycomp mg1 mg2++  logm $ "clientModsAndFiles:clients=" ++ show clients+  logm $ "clientModsAndFiles:clients'=" ++ show clients'+  return clients'++-- 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+-- TODO: make sure this works with multiple targets. Is that needed? No?+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 = gfromJust "serverModsAndFiles" $ 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++-- ---------------------------------------------------------------------++{- ++AZ++ what is using this?+-- | 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 <- getCurrentModuleGraph+  let scc = GHC.topSortModuleGraph False g Nothing+  return scc+++++AZ++ -}+