PFEdeps.hs

module PFEdeps(
   PFE5MT,runPFE5,clean5,getSt5ext,updSt5ext,setSt5ext,
   --Dep,Deps,deps0,
   tdepModules,tdepModules',depModules,depModules',
   tdefinedNames,isDefaultDecl,isInstDecl,splitDecls)
 where
import Prelude hiding (readFile,readIO)
import Maybe(fromMaybe)
import List(nub,sort)

import HsModule
import HsIdent(getHSName,HsIdentI(..))
import HasBaseStruct(basestruct,hsTypeSig,hsInfixDecl)
import HasBaseName(getBaseName)
import HsDeclStruct(DI(..))
import SrcLoc1(srcLoc)
import TypedIds(IdTy(..))

import QualNames(mkUnqual)
import PNT(PNT(..))
import UniqueNames(noSrcLoc)
--import TiNames(idTy)
--import TiModule() -- instance HasIdTy PNT -- grr!

import PFE0
import PFE2(getModuleTime)
import PFE3(parseModule)
import PFE4(PFE4MT,getSt4ext,updSt4ext,clean4,runPFE4,typeCheckModule)
import TiClasses(fromDefs)
import TiNames(instName,defaultName,derivedInstName)
import DefinedNames(definedNames,addName,classMethods,contextSize)
import TiDefinedNames(definedTypeName)
import FreeNames(freeNames) --freeValues
import PrettyPrint
import MUtils
import AbstractIO
import FileUtils
import DirUtils(optCreateDirectory,getModificationTimeMaybe,rmR)

type Dep n = [([n],([n],[Hash]))] -- tricky to use correctly, should be abstract!!
type Deps n = [(ModuleName,(ClockTime,Dep n))]
type Deps2 n = (Deps n,Deps n)

deps0 = [] :: Deps n

type PFE5MT n i1 i2 ds1 ds2 ext m = PFE4MT n i1 i2 ds1 ds2 (Deps2 i2,ext) m

runPFE5 ext = runPFE4 ((deps0,deps0),ext)

getSt5 :: Monad m => PFE5MT n i1 i2 ds1 ds2 ext m (Deps2 i2)
updSt5 :: Monad m => Upd (Deps2 i2)->PFE5MT n i1 i2 ds1 ds2 ext m ()
getSt5ext :: Monad m => PFE5MT n i1 i2 ds1 ds2 ext m ext
updSt5ext :: Monad m => Upd ext->PFE5MT n i1 i2 ds1 ds2 ext m ()

getSt5 = fst # getSt4ext
updSt5 = updSt4ext . apFst 
setSt5 = updSt5 . const

getSt5ext = snd # getSt4ext
updSt5ext = updSt4ext . apSnd
setSt5ext = updSt5ext . const

type Hash = Int

hash =
    checksum . quickrender . withPPEnv hashmode . ppi
  where
    checksum = foldr (\c h->3*h+fromEnum c) 0
    hashmode = defaultMode{layoutType=PPNoLayout,typeInfo=False}

-- Compute the dependency info for all modules in the project:
depModules = depModules' Nothing
tdepModules = tdepModules' Nothing

-- Update the dependeny info for a selected set of modules in the project:
depModules' optms =
    do (olddeps,oldtdeps) <- getSt5
       newdeps <- depModules'' olddeps syntaxDeps optms
       setSt5 (newdeps,oldtdeps)
       return newdeps
  where
    syntaxDeps = (depFile,untypedParse,True)
    untypedParse = fmap dup . parseModule'

tdepModules' optms =
    do (olddeps,oldtdeps) <- getSt5
       newtdeps <- depModules'' oldtdeps typedDeps optms
       setSt5 (olddeps,newtdeps)
       return newtdeps
  where
    typedDeps = (tdepFile,typedParse,False)
    typedParse m = (,) # parseModule' m <# typeCheckModule m
                   -- The module is parsed twice!

parseModule' = fmap snd . parseModule

depModules'' olddeps depsrc optms =
    do optCreateDirectory `projPath` depdir
       ms <- maybe allModules return optms
       updateDeps depsrc olddeps ms


updateDeps (depFile,parseMod,allInst) olddeps ms =
    do newdeps <- mapM upd ms
       let changed = map fst newdeps
           deps = newdeps++filter ((`notElem` changed).fst) olddeps
       return deps
  where
    
    upd m =
      do let olddep = lookup m olddeps
	 t <- getModuleTime m
	 if t `newerThan` (fst # olddep)
           then do dept <- maybeF getModificationTimeMaybe depf
		   if t `newerThan` dept then again else useOld dept
	   else return (m,fromJust' "PFEdeps.hs:124" olddep)

      where
        depf = depFile m
		   
        again =
          do epput $ "Extracting dependencies:"<+>m
             dep <- dependencies allInst # parseMod m
	     t <- updateDep depf dep
	     return (m,(t,dep))

        useOld dept =
           do dir <- fromJust' "PFEdeps.hs:120" # projectDir
	      let path = depf dir
		  ret dep = return (m,(fromJust' "PFEdeps.hs:123" dept,dep))
              --ret . read'' path =<< readFile path -- lazy
	      maybe again ret =<< maybeM (readIO =<< readFile path) -- strict

    updateDep depf dep =
      do optdir <- projectDir
         case optdir of
           Nothing -> getClockTime
	   Just dir ->
             do updated <- updateFile' (depf dir) (show dep)
	        getModificationTime (depf dir)

{-+
The hash is computed from the source AST, while the set of free names in
a declaration is computed from the type checked AST, to catch dependencies
on instances, which are made explicit by the dictionary translation.
Things like derived instances that do not appear in the source code
will be assigned hash value [].
-}
dependencies allInst (untyped,typed) = udeps++deps
  where
    deps0 = [(rdefs d,rfree d)|d<-fromDefs (hsModDecls typed)]
    udeps = [([],(fvs,[]))|([],fvs@(_:_))<-deps0]
    deps1 = mapSnd (nub.concat) $ collectByFst [(n,fvs)|(ns,fvs)<-deps0,n<-ns]
    deps  = [([n],(fvs,findHash n))|(n,fvs)<-deps1]
    findHash n = nub $ sort [h|(n',h)<-hs,n'==n]
    hs = [(n,h)|d<-fromDefs (hsModDecls untyped),let h=hash d,n<-rdefs d]

    mn = getBaseName (hsModName typed)
    rdefs = map getHSName . tdefinedNames allInst mn
    rfree = restrict . tfreeNames mn
    restrict = nub . concatMap (addowner.getHSName)
    --restrict = map getHSName

    addowner x = if o==x then [x] else [o,x]
      where o = owner x

    -- Map subordinate names to their owner (reduces the total number of names):
    owner x =
	case idty x of
	  ConstrOf t ty -> pnt t (Type ty)
	  FieldOf t ty -> pnt t (Type ty)
	  MethodOf c n ms -> pnt c (Class n ms)
	  _ -> x
      where
	pnt t idty = PNT (mkUnqual t) idty noSrcLoc
	idty (PNT _ ty _) = ty


-- To track dependencies on instances, include the names assigned to
-- instances by the type checker.
-- Also, to keep relevant type signatures and infix declarations, pretend that
-- they are part of the definitions of the identifiers the mention.
tdefinedNames allInst m d =
  case basestruct d of
    Just (HsInstDecl s optn ctx inst ds) -> if allInst then [] else [HsVar n]
      where n = fromMaybe (instName m s inst) optn
    Just (HsTypeSig s is c t) -> map HsVar is
    Just (HsInfixDecl s f is) -> is
    _ -> ns
  where ns = map fst (definedNames (addName d))

{-
Since the type checker lifts default methods out from the class declaration
to the top level, we make the class declaration depend on the default
methods, under the assumption that they will be included in slices if
the class is included...
-}
tfreeNames m d =
  case basestruct d of
    Just (HsDataDecl s c tp cs cls) ->
        [HsVar (derivedInstName m cl tn)|cl<-cls]++ns
      where tn = definedTypeName tp
    Just (HsClassDecl s c t fd ds) ->
         map fst (freeNames d)++map (fmap defaultName) methods
       where
         methods = map fst (classMethods undefined (contextSize c) ds)
    _ -> ns
  where ns = map fst (freeNames d)

isDefaultDecl d =
  case basestruct d of
    Just (HsDefaultDecl{}) -> True
    _ -> False

isInstDecl d =
  case basestruct d of
    Just (HsInstDecl{}) -> True
    _ -> False

{-+
To make it ease to include the right infix declarations and type signatures,
split them. For example, if * is needed but / is not, you can't keep or throw
away all of the infix declaration "infixl 7 *,/".
-}
splitDecls = concatMap splitDecl
splitDecl d =
  case basestruct d of
    Just (HsTypeSig s is c t) -> [hsTypeSig s [i] c t|i<-is]
    Just (HsInfixDecl s f is) -> [hsInfixDecl s f [i]|i<-is]
    _ -> [d]

--------------------------------------------------------------------------------
clean5 = withProjectDir clean
  where
    clean dir = do rmR [depdir dir]
		   clean4

--------------------------------------------------------------------------------

depdir dir=dir++"dep/"

depFile m dir = depdir dir++moduleInfoPath m++".g"
tdepFile m dir = depdir dir++moduleInfoPath m++".tg"
--------------------------------------------------------------------------------