HaRe-0.6: refactorer/PFE0.hs
-- Programatica Front-End, level 0, see README.html
module PFE0(
PFE0MT,runPFE0,clean0,PFE0State, PFE0_IO, HasInfixDecls,
pput,epput,
Upd,getSt0ext,updSt0ext,setSt0ext, -- for extending the state
ModuleNode,ModuleGraph,
getCurrentModuleGraph,sortCurrentModuleGraph,getSortedSubGraph,getSubGraph,
allModules,allFiles,moduleList,
findFile,findFile',findNode,findNode',
getModuleInfixes,getModuleImports,
updateModuleGraph,
parserFlags,ppFlags,
batchMode,setBatchMode,
newProject,addPaths,removePaths,saveSrcList,checkProject,projectStatus,
lex0SourceFile,preparseModule,preparseSourceFile,lexAndPreparseSourceFile,
projectDir,projPath,maybeF,withProjectDir,withProjectDir',newProjectHelp,
moduleInfoPath,
-- Pure functions:
optSubGraph,subGraph,
-- Independent of PFE:
moduleNode,newerThan,
-- managing HaRe file history
clearHistory, addToHistory, undoLatestInHistory,
-- Hare editor interface
getEditorCmds, State0, editorCmds, getSt0
) where
import Prelude hiding (readFile,writeFile,putStr,putStrLn,catch,ioError)
import List(sort,nub,(\\))
import Monad(when,unless)
import Maybe(fromMaybe,fromJust,isJust)
import HsModule
import HsAssocStruct
import HsIdent
import ReAssoc(HasInfixDecls,getInfixes)
import NamesEntities(getQualified)
import QualNames(QualNames)
import SourceNames(SN,fakeSN)
import HasBaseName(getBaseName)
import MUtils(( # ),(@@),done,collectByFst,mapFst,apFst,apSnd,ifM,seqMaybe)
import SimpleGraphs(reverseGraph,reachable)
--import EnvMT
import MT (MT(..))
import StateMT(WithState,withSt,withStS,getSt,setSt,updSt,updSt_)
import DirUtils
import FileUtils hiding (readFileNow)
import AbstractIO
import NewSCC(scc)
import PPU
import CmdLineParser3
import ParserOptions
import ParseMonad(PM)
import Unlit(readHaskellFile)
import ParseMonad(parseTokens)
import HsLexerPass1(Lexer)
import HsLexMerge(mergeLex)
import EditorCommands
import qualified Control.OldException as CE (catch)
--------------------------------------------------------------------------------
-- Types manipulated at PFE level 0:
type ModuleNode = (FilePath,(ModuleName,[ModuleName]))
type ModuleGraph = [ModuleNode]
type SortedModuleGraph = [ModuleGraph] -- strongly connected components
type Fixities n = [(HsIdentI n,HsFixity)]
type ModuleFixities n = [(ModuleName,Fixities n)]
--------------------------------------------------------------------------------
--type PFE i ds m a = WithEnv (Parser i ds m) m a
--type Parser i ds m = FilePath -> m (HsModuleI i ds)
--pfe :: (PFE_IO m, DefinedNames (SN HsName) ds, HasInfixDecls (SN HsName) ds)
-- => (Maybe String->Parser (SN HsName) ds m) -> [String] -> m ()
--type PFE0Env i ds = ((Flags,(Bool,PPHsMode)),(Lexer,PM (HsModuleI i ds)))
data State0 n i ds = PFE0 { myname :: String,
batch :: Bool,
cacheDir :: Maybe FilePath,
parserOpts :: ParserOptions.Flags,
ppOpts :: (Bool,PPHsMode),
lexer :: Lexer,
parser :: PM (HsModuleI (SN ModuleName) i ds),
fixities :: ModuleFixities n,
srclist :: [FilePath],
tgraph :: Maybe (Maybe ClockTime,ModuleGraph),
sortedgraph :: Maybe SortedModuleGraph ,
editorCmds :: EditorCmds ,
history :: [(Bool,[(String,String)])] }
initState0 name (lexer,parser)
= PFE0 { myname = name, -- name of command, for usage message
batch = True, -- batch mode (always trust data in internal caches)
cacheDir = Nothing, -- location of current project cache
parserOpts = flags0,
ppOpts = ppOpts0,
lexer = lexer,
parser = parser,
fixities = [],
srclist = [],
tgraph = Nothing,
sortedgraph = Nothing,
editorCmds = commandlineCmds ,
history = [] }
graph st = snd # tgraph st
-- Old:
--type PFE0Info n = (ModuleGraph,ModuleFixities n)
--pfe0info st = (graph st,fixities st)
getEditorCmds = editorCmds # getSt0
-- Leave room for extending the state (poor man's subtyping):
type PFE0State n i ds nextlevel = (State0 n i ds,nextlevel)
type PFE0MT n i ds ext m = WithState (PFE0State n i ds ext) m
withPFE0 :: Monad m => PFE0State n i ds ext -> PFE0MT n i ds ext m a -> m a
withPFE0 = withSt
{-+
All level 0 functions work in arbitrary monads that provide access to
the level 0 state (and some other things). The following type
signatures *restricts* level 0 functions to the PFE0MT monad transformer.
We don't need the extra generality at the moment and the restriction
should make the inferred types more readable (but since
GHC doesn't do any context reduction, they are still not very
readable...)
-}
type Upd s = s->s
getSt0 :: Monad m => PFE0MT n i ds ext m (State0 n i ds)
updSt0 :: Monad m => Upd (State0 n i ds)->PFE0MT n i ds ext m ()
getSt0ext :: Monad m => PFE0MT n i ds ext m ext
updSt0ext :: Monad m => Upd ext->PFE0MT n i ds ext m ()
getSt0 = fst # getSt
updSt0 = updSt_ . apFst
setSt0 = updSt0 . const
getSt0ext = snd # getSt
updSt0ext = updSt_ . apSnd
setSt0ext = updSt0ext . const
batchMode = batch # getSt0
setBatchMode b = updSt0 $ \st->st{batch=b}
{- the definition from Programatica.
runPFE0 ext pfeM lexerAndParser (opts,name,args0) =
do let st0 = (initState0 name lexerAndParser){ppOpts=opts}
withPFE0 (st0,ext) $ pfeM (name++" [options]") =<< initProject args0
-}
--------------------------------------------------------------------------
-- HaRe redefined runPFE0. (was called runLoopPFE0).
runPFE0 ext pfeM lexerAndParser (opts,name,args0) = do
let st0 = (initState0 name lexerAndParser){ppOpts=opts}
withPFE0 (st0,ext) $ editorLoop (name++" [options]") =<< initProject args0
where
editorLoop prg ("emacs":args) = do
updSt0 $ \st->st{editorCmds=emacsCmds}
loop prg args
editorLoop prg ("vim":(vimPath:(vimServerName:args))) = do
editorCmds <- mkVimCmds vimPath vimServerName
updSt0 $ \st->st{editorCmds=editorCmds}
loop prg args
editorLoop prg args = do
loop prg args
loop prg args = do
editorCmds <- editorCmds # getSt0
let getCmd = lift (getEditorCmd editorCmds)
sendMsg dialog msg = lift (sendEditorMsg editorCmds dialog msg)
sendModified f = lift (sendEditorModified editorCmds f)
l <- catchEnv getCmd (const $ return "stop")
let cmdArgs@(cmd: ~(mod:_)) = words l
sendMsg False $ "CMD:"++show cmdArgs
unless (cmd=="stop") $ do
if (cmd=="undo") then (undoLatestInHistory >> loop prg args)
else do when (cmd == "new") clearHistory
-- refactorings currently use exceptions freely:-(
-- AbstractIO defined catch as Prelude.catch, which doesn't
-- capture all exceptions; we need Control.Exception.catch..
-- we also need catch embedded in environment monad (catchEnv)
-- [now changed into state transformer..]
-- in the longer term, we need to avoid fatal exceptions within
-- refactorings, switching to Either or least to user exceptions!
-- NOTE: we need a placeholder for semantic information, to be
-- filled in and kept up-to-date by refactorings as they
-- find they need to parse&analyse files in the project;
-- that placeholder/semantic info will then have to be
-- passed from one iteration to the next here
-- in the new programatica sources, "new"/"chase" don't seem to
-- update the project state; as a workaround, we reinitialise
-- in each loop..
catchEnv (do initProject args0
setBatchMode False
pfeM prg cmdArgs)
(\e ->sendMsg True $ "CAUGHT EXCEPTION: " ++ show e)
loop prg args
catchEnv m f = do s <- getSt
(r,s) <- lift (withStS s m `CE.catch` (withStS s . f))
setSt s
return r
------------------------------------------------------------------------
-- managing the refactoring history, which is of type
-- [[(Filename,Filecontents)]], where both names and contents are Strings
clearHistory = updSt0 (\s->s{history=[]})
-- refactorer currently extends history whenever
-- called upon, even if the editor file has been
-- reset in the meantime!! need more communication
-- between editor and refactorer
addToHistory isSubRefactor files = do sources <- mapM readFileNow files
updSt0 (\s->s{history=((isSubRefactor,(zip files sources)):(history s))})
undoLatestInHistory = do
history <- history # getSt0
editorCmds <- editorCmds # getSt0
let sendModified f = lift (sendEditorModified editorCmds f)
sendMsg dialog msg = lift (sendEditorMsg editorCmds dialog msg)
case skipHistory ([],history) of
(f@(file:files),rest) ->
do mapM_ (\(name,source)->writeFile name source >> sendModified name) f
updSt0 (\s->s{history=rest})
_ -> do sendMsg True "no refactorer undo history"
readFileNow name = do -- make sure file is read completely
contents <- readFile name
seq (length contents) $ return contents
skipHistory (r, []) =(r,[])
{- flag: True means the back-up id for sub-refactoring. This function aims to help
undoing composite refactorings
-}
skipHistory (r,h@((flag,files):rest))
= if flag then skipHistory (((diffHistory r files)++ files),rest) -- handle sub-refactoring
else (((diffHistory r files)++files), rest)
where
diffHistory::[(String,String)]->[(String,String)]->[(String,String)]
diffHistory h1 h2 = filter (\(filename,content)->not (elem filename filenames)) h1
where filenames = map fst h2
------------------------------------------------------------------------
initProject args0 =
do res <- try loadSrcList
case res of
Left err ->
if isDoesNotExistError err
then blankProject args0
else ioError err
Right files -> openProject projdir args0
where
projdir = defaultProjectDir
loadSrcList =
do paths <- lines # readFileNow (srclistPath projdir)
setSrcList paths
clearGraph
return paths
blankProject args0 =
do flags0 <- parserFlags
let (flags,args) = parserOptions flags0 args0
updSt0 $ \st->st{parserOpts=flags}
return args
openProject dir args0 =
do updSt0 $ \st->st{cacheDir=Just dir}
flags0 <- parserFlags
let opath = optionsPath dir
flags1 <- fromMaybe flags0 # (readFileMaybe opath)
let (flags,args) = parserOptions flags1 args0
updSt0 $ \st->st{parserOpts=flags}
--quietUpdateModuleGraph
when (flags/=flags1) $ writeFile opath (show flags)
return args
setpfe0info (tg,fs) =
updSt0 $ \st->st{tgraph=Just tg,fixities=fs,sortedgraph=Nothing}
newProject =
do let dir=defaultProjectDir
optCreateDirectory dir
updSt0 $ \st->st{cacheDir=Just dir}
setSrcList []
setpfe0info ((Nothing,[]),[])
let opath = optionsPath dir
writeFile opath . show =<< parserFlags
updateModuleGraph
clearGraph = updSt0 $ \st->st{fixities=[],tgraph=Nothing,sortedgraph=Nothing}
saveSrcList paths =
do setSrcList paths
flip updateFile_ (unlines . set $ paths) `projPath` srclistPath
setSrcList paths = updSt0 $ \st->st{srclist=paths}
preparseModule = preparseSourceFile @@ findFile
preparseSourceFile path =
do flags <- parserOpts # getSt0
optAddPrelude fakeSN (prel flags) #
(parseFile path =<< readHaskellFile (cpp flags) path)
where
parseFile path (litcmnts,code) =
do PFE0 {lexer=lexerPass0,parser=parseModule} <- getSt0
parseTokens parseModule path (lexerPass0 code)
-- lexAndPreparseSourceFile :: (HasEnv m PFE0Env, FileIO m) =>
-- => FilePath -> m ([(Token,(Pos,String))],HsModuleI i)
lexAndPreparseSourceFile path =
do PFE0{parserOpts=flags,lexer=lexerPass0,parser=parseModule} <- getSt0
lts@(_,ts) <- apSnd lexerPass0 # readHaskellFile (cpp flags) path
m <- optAddPrelude fakeSN (prel flags) # parseTokens parseModule path ts
return (mergeLex lts,m)
lex0SourceFile path =
do PFE0{parserOpts=flags,lexer=lexerPass0} <- getSt0
apSnd lexerPass0 # readHaskellFile (cpp flags) path
parserFlags = parserOpts # getSt0
ppFlags = ppOpts # getSt0
-- Pretty print with options from PFE environment and put on stdout:
pput x =
do o <- ppFlags
putStrLn$ ppu o $ x
-- Pretty print with options from PFE environment and put on stderr:
epput x =
do o <- ppFlags
ePutStrLn$ ppu o $ x
findFile m = fst # findNode m
findNode m = findNode' m =<< getCurrentModuleGraph
findFile' :: (Functor m, Monad m) => ModuleName -> ModuleGraph -> m FilePath
findFile' m g = fst # findNode' m g
findNode' :: Monad m => ModuleName -> ModuleGraph -> m ModuleNode
findNode' m g =
case [n|n@(_,(m',_))<-g,m'==m] of
[n] -> return n
[] -> fail $ pp $ "Unknown module:"<+>m
_ -> fail $ pp $ "Module defined in several files:"<+>m
getModuleImports m = snd . snd # findNode m
getCurrentModuleGraph =
do ifM (isJust . graph # getSt0) done quietUpdateModuleGraph
fromJust . graph # getSt0
sortCurrentModuleGraph =
do optsg <- sortedgraph # getSt0
case optsg of
Just sg -> return sg
_ -> do g <- getCurrentModuleGraph
case checkGraph g of
Just errs -> fail $ pp $ moduleGraphReport errs
_ -> do let sg = sortGraph g
updSt0 $ \st->st{sortedgraph=Just sg}
return sg
getSubGraph optms = concat # getSortedSubGraph optms
getSortedSubGraph optms = flip optSubGraph optms # sortCurrentModuleGraph
projectDir = cacheDir # getSt0
withProjectDir' n m = maybe n m =<< projectDir
withProjectDir = withProjectDir' done
allModules = moduleList # sortCurrentModuleGraph
allFiles = srclist # getSt0
getModuleInfixes = fixities # getSt0
moduleList g = [m|scc<-g,(_,(m,_))<-scc]
projectStatus =
do checkProject
files <- allFiles
if null files
then do putStrLn "You have a new, empty project."
putStrLn "Add files to it by using: pfe add <files>"
else do let n = length files
putStrLn $ "The project contains "++
if n==1
then "one source file."
else show (length files)++" source files."
putStrLn "(To list the files, use: pfe files)"
updateModuleGraph -- skip?
checkProject = withProjectDir' newProjectHelp return
newProjectHelp =
do name <- myname # getSt0
fail $ "Start by creating a new project using "++
name++" new or pfesetup"
addPaths = changePaths (++)
removePaths = changePaths (\\)
changePaths op quiet paths =
do checkProject
old <- allFiles
new <- expand paths
let files = old `op` paths
saveSrcList files
--optUpdateModuleGraph
updateModuleGraph' quiet
sortGraph :: ModuleGraph -> [ModuleGraph]
sortGraph g = map (map post) . scc . map snd $ g
where
mfs = [(n,f)|(f,(n,_))<-g]
post (n,is) = (fromMaybe (error "PFE0.sortGraph") $ lookup n mfs,(n,is))
checkGraph g =
if null dups && null missing
then Nothing
else Just (dups,missing)
where
dups = filter duplicated mfs
where duplicated (m,fs) = length fs/=1
mfs = collectByFst [(m,f)|(f,(m,_))<-g]
known = set (map fst mfs)
missing = collectByFst [(i,m)|(_,(m,is))<-g,i<-is,i `notElem` known]
moduleGraphReport (mfs,missing) = reportDuplicates $$ reportMissing
where
reportDuplicates = sep (map reportDuplicate mfs)
reportMissing = if null missing
then empty
else sep [ppi "Source files missing for (add files with 'pfe add' or 'pfe chase'): ",
nest 4 (vcat (map needed missing))]
where needed (i,ms) = i<>","<+>"needed by"<+>fsep ms
reportDuplicate (m,fs) = m<+>"defined in more than one file:"<+>fsep fs
optUpdateModuleGraph = ifM (isJust . graph # getSt0) updateModuleGraph done
quietUpdateModuleGraph = updateModuleGraph' True
updateModuleGraph = updateModuleGraph' False
-- Another type signature to improve the readablility of inferred types:
updateModuleGraph' ::
(PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>
Bool -> PFE0MT n i ds ext m ()
updateModuleGraph' quiet =
do files <- allFiles
tg <- optLoadModuleGraph files
ofix <- getModuleInfixes
(g,fixities) <- unzip # mapM (updateModuleImports ofix tg) files
-- The graph written to modgraphPath must be current, since source files
-- are reread only if they are newer than modgraphPath!
flip writeFile (show g) `projPath` modgraphPath
t <- maybe getClockTime return =<<
getModificationTime' `projPath` modgraphPath
updateGraphTextFiles g
let r = maybe [] (pp . moduleGraphReport) (checkGraph g)
unless (quiet || null r) $ ePutStrLn r
--saveSrcList files
setpfe0info ((Just t,g),fixities)
where
optLoadModuleGraph files =
maybe (loadModuleGraph files) return . tgraph =<< getSt0
loadModuleGraph files =
do optgpath <- fmap modgraphPath # projectDir
case optgpath of
Just gpath ->
do g <- (readM =<< readFile gpath) `catch` const (return [])
t <- if null g
then return Nothing
else Just # getModificationTime' gpath
return (t,g::ModuleGraph)
_ -> return (Nothing,[])
updateModuleImports ofix (gt,g) modulePath =
case lookup modulePath g of
Nothing -> getModuleImports modulePath
Just mi ->
ifM ((`newerThan` gt) # getModificationTime' modulePath)
(getModuleImports modulePath)
(useOldImports ofix modulePath mi)
getModuleImports modulePath =
do m <- preparseSourceFile modulePath
m_infixes <- updateInfixes m
let node = moduleNode m
return ((modulePath,node),m_infixes)
useOldImports oldfixities modulePath mi@(mn,_) =
do infixes <- case lookup mn oldfixities of
Just infixes -> return infixes
_ -> withProjectDir' no yes
where yes dir = readM=<<readFile (infixFile dir mn)
no = fail$"Missing fixity info for: "++show mn
return ((modulePath,mi),(mn,infixes))
--updateInfixes :: (Printable i,HasInfixDecls i ds,HasIO m) => HsModuleI i ds -> m Bool
updateInfixes m =
do let infixes = mapFst getQualified (getInfixes (hsModDecls m))
mn = getBaseName (hsModName m)
upd dir = do optCreateDirectory (infixdir dir)
updateFile_ (infixFile dir mn) (show infixes)
withProjectDir upd
return (mn,infixes)
updateGraphTextFiles fg = withProjectDir upd
where
upd dir = do updateFile_ (dir++"ModuleSourceFiles.txt") (txt2 fg)
updateFile_ (dir++"ModuleGraphRev.txt") (txtn rg)
g = map snd fg
rg = reverseGraph g
txtn = unlines . map (\(m,is)->pp m++" "++unwords (map pp is))
txt2 = unlines . map (\(f,(m,_))->pp m++" "++f)
moduleNode m = (getBaseName (hsModName m),{-set$-} map getBaseName (hsModImportsFrom m))
--------------------------------------------------------------------------------
t `newerThan` Nothing = True
t `newerThan` Just t' = t>t'
set xs = sort (nub xs)
optSubGraph g = maybe g (subGraph g)
subGraph g ms = [scc|scc<-g,any (`elem` r) [m|(_,(m,_))<-scc]]
where r = reachable (map snd (concat g)) ms
updateFile_ path str = updateFile path str >> done
maybeF m f = maybe (return Nothing) (m.f) =<< projectDir
m `projPath` f = do d <- fmap f # projectDir
seqMaybe (fmap m d)
--------------------------------------------------------------------------------
clean0 = withProjectDir clean
where
clean dir =
rmR [modgraphPath dir,
dir++"ModuleSourceFiles.txt",
dir++"ModuleGraphRev.txt",
infixdir dir]
>>done
--------------------------------------------------------------------------------
defaultProjectDir = "hi/"
infixdir dir=dir++"infix/"
srclistPath dir= dir++"srclist.txt"
modgraphPath dir= dir++"FileModules.hv"
optionsPath dir= dir++"options"
infixFile dir m = infixdir dir++moduleInfoPath m++".hv"
moduleInfoPath m = map conv (pp (m::ModuleName))
where
conv '/' = '-'
conv '\\' = '_'
conv ':' = '_'
conv c = c
--------------------------------------------------------------------------------
{-
instance CatchIO err m => CatchIO err (WithEnv e m) where
m `catch` f = do e <- getEnv
lift (withEnv e m `catch` (withEnv e . f))
ioError = lift . ioError
-}
instance CatchIO err m => CatchIO err (WithState s m) where
m `catch` f = do s0 <- getSt
(a,s1) <- lift $ withStS s0 m `catch` (withStS s0 . f)
setSt s1
return a
ioError = lift . ioError
-- a class synonym:
class (FileIO m,DirectoryIO m,CatchIO e m,StdIO m,SystemIO m,TimeIO m) => PFE0_IO e m | m->e
instance (FileIO m,DirectoryIO m,CatchIO e m,StdIO m,SystemIO m, TimeIO m) => PFE0_IO e m