PFE0.hs

module PFE0(
    PFE0MT,runPFE0,clean0,
    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
  ) 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
import AbstractIO
import NewSCC(scc)
import PPU
import ParserOptions
import ParseMonad(PM)

import Unlit(readHaskellFile)
import ParseMonad(parseTokens)
import HsLexerPass1(Lexer)
import HsLexMerge(mergeLex)

--------------------------------------------------------------------------------
-- 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 :: Bool->Lexer,
			    parser :: PM (HsModuleI (SN ModuleName) i ds),
			    fixities :: ModuleFixities n,
			    srclist :: [FilePath],
			    tgraph :: Maybe (Maybe ClockTime,ModuleGraph),
			    sortedgraph :: Maybe SortedModuleGraph }

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 }

graph st = snd # tgraph st
-- Old:
--type PFE0Info n = (ModuleGraph,ModuleFixities n)
--pfe0info st = (graph st,fixities st)


-- 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 

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 x = updSt0 (const x)

getSt0ext = snd # getSt
updSt0ext = updSt_ . apSnd
setSt0ext x = updSt0ext (const x)

batchMode :: Monad m => PFE0MT n i ds ext m Bool
batchMode = batch # getSt0
setBatchMode b = updSt0 $ \st->st{batch=b}

getLexer () = do PFE0{lexer=l,parserOpts=flags} <- getSt0
	         return (l (plogic flags))
              
runPFE0 ext pfeM lexerAndParser (opts,name,args0) =
  do let st0 = (initState0 name lexerAndParser){ppOpts=opts}
     withPFE0 (st0,ext) $ pfeM (name++" [options]") =<< initProject args0

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 # readFile (srclistPath projdir)
	 setSrcList paths
	 clearGraph ()
	 return paths

    clearGraph () =
      updSt0 $ \st->st{fixities=[],tgraph=Nothing,sortedgraph=Nothing}

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 ::
  (PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>
  PFE0MT n i ds ext m ()
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

saveSrcList paths =
  do setSrcList paths
     flip updateFile_ (unlines . set $ paths) `projPath` srclistPath

setSrcList paths = updSt0 $ \st->st{srclist=paths}

preparseModule m = preparseSourceFile =<< findFile m

preparseSourceFile path =
  do flags <- parserFlags
     optAddPrelude fakeSN (prel flags) #
	(parseFile path =<< readHaskellFile (cpp flags) path)
  where
    parseFile path (litcmnts,code) = 
      do parseModule <- parser # getSt0
	 lexerPass0 <- getLexer()
	 parseTokens parseModule path (lexerPass0 code)

-- lexAndPreparseSourceFile :: (HasEnv m PFE0Env, FileIO m) =>
--  => FilePath -> m ([(Token,(Pos,String))],HsModuleI i)
lexAndPreparseSourceFile path =
  do PFE0{parserOpts=flags,parser=parseModule} <- getSt0
     lexerPass0 <- getLexer()
     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} <- getSt0
     lexerPass0 <- getLexer()
     apSnd lexerPass0 # readHaskellFile (cpp flags) path

parserFlags :: (Functor m,Monad m) => PFE0MT n i ds ext m (ParserOptions.Flags)
parserFlags = parserOpts # getSt0

ppFlags :: (Functor m,Monad m) => PFE0MT n i ds ext m (Bool,PPHsMode)
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 ::
  (PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)
   => PFE0MT n i ds ext m ModuleGraph
getCurrentModuleGraph =
  do ifM (isJust . graph # getSt0) done quietUpdateModuleGraph
     fromJust . graph # getSt0

sortCurrentModuleGraph ::
  (PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)
   => PFE0MT n i ds ext m [ModuleGraph]
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 :: (Functor m,Monad m) => PFE0MT n i ds ext m (Maybe FilePath)
projectDir = cacheDir # getSt0
withProjectDir' n m = maybe n m =<< projectDir
withProjectDir x = withProjectDir' done x

allModules ::
  (PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)
   => PFE0MT n i ds ext m [ModuleName]
allModules = moduleList # sortCurrentModuleGraph

allFiles :: (Functor m,Monad m) => PFE0MT n i ds ext m [FilePath]
allFiles = srclist # getSt0

getModuleInfixes :: (Functor m,Monad m) => PFE0MT n i ds ext m (ModuleFixities n)
getModuleInfixes = fixities # getSt0

moduleList g = [m|scc<-g,(_,(m,_))<-scc]

projectStatus ::
  (PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>
  PFE0MT n i ds ext m ()
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 :: (Functor m,Monad m) => PFE0MT n i ds ext m FilePath
checkProject = withProjectDir' newProjectHelp return

newProjectHelp :: (Functor m,Monad m) => PFE0MT n i ds ext m a
newProjectHelp =
    do name <- myname # getSt0
       fail $ "Start by creating a new project using "++
	      name++" new or pfesetup"

addPaths q = changePaths (++) q
removePaths q = changePaths (\\) q

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,quietUpdateModuleGraph,updateModuleGraph ::
  (PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>
  PFE0MT n i ds ext m ()
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 :: SystemIO m =>  PFE0MT n i ds ext m ()
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 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