content: module PfeAlfaCmds(pfeAlfaCmds) where
  import Prelude hiding (putStrLn,writeFile,catch)
  import Monad(filterM)
  import Maybe(mapMaybe)
  import List(intersect)
  
  import HsModule
  
  import RemovePatBinds(remPats)
  import RemoveListCompProp(rmAllListComp)
  import SimpFunBind(simpAllFunBind)
  import SimpPatMatch(simpAllPatMatch,getSimpPatIds,prelError)
  --import SimpFieldLabels(simpFieldLabels)
  import DefinedNames(addName)
  import PFE4(rewriteAndTypeCheck)
  import PFE_Rewrites(Rewrite(..),compRw,pmRewrite,pbRewrite,lcRewrite)
  import PFE0(moduleList,subGraph,newerThan,getSortedSubGraph)
  import PfeParse(moduleArgs',kwOption,just)
  import TI((+++))
  import TiModule(joinModules,representative)
  
  import Prop2Alfa(transModule,modPath)
  import BaseStruct2Alfa(packageSynonym,joinModuleNames)
  --import FileConv(printModule)
  import qualified UAbstract as U
  
  import AbstractIO
  import DirUtils(getModificationTimeMaybe)
  import MUtils
  import EnvM(withEnv)
  
  pfeAlfaCmds =
    [--("alfa",(moduleArgs prop2alfa1,"translate modules to Alfa")),
     ("alfa",(moduleArgs' opt prop2alfa,"translate modules to Alfa"))]
    where
      opt = kwOption "-simplepats"
  
  prop2alfa simplepats = if simplepats then prop2alfa2 else prop2alfa1
  
  prop2alfa1 = prop2alfa' rewrite1
  prop2alfa2 = prop2alfa' rewrite2
  
  rewrite1 = pmRewrite `compRw` rewrite2
  rewrite2 = pbRewrite `compRw` lcRewrite `compRw` addNameRw
  addNameRw = Rewrite "an" (return addName)
  
  prop2alfa' rewrite@(Rewrite rwname _) ms =
      do dir <- getEnv "APFE_DIR" `catch` const (return "alfa")
         changedsccs <- changedSccs dir =<< getSortedSubGraph (just ms)
         let ms = concat changedsccs
         if null ms then done
           else do tms <- rewriteAndTypeCheck rewrite  (Just ms)
                   mapM_ (transSCC dir tms) changedsccs
    where
      transSCC dir alltms ms = mapM (writeModule dir . trans1) ms
        where
          joinedmn = joinModuleNames ms
  	rm = representative ms
  	tms = [(m,tm)|(m,(_,(tms,_)))<-alltms,m `elem` ms,(rwn,tm)<-tms,rwn==rwname++"fl"]
  	joinedtm = joinModules (map snd tms)
  
          trans1 m = (m,U.Module transm)
            where
              transm = if m==rm
  	             then transds ++ syn
  	             else imp:syn
  
              U.Module transds = withEnv (ms,env) (transModule joinedtm)
              syn = if m==joinedmn then [] else packageSynonym m joinedmn
  	    imp = U.ImportDecl (U.Import (modPath rm))
  
          env = foldr ((+++).snd.snd.snd.snd) ([],[]) alltms
  
  {-
  prop2alfa1 =
      mapM_ writeModule.transModules @@ rewriteAndTypeCheck rewrite.Just
    where
      transModules ms = mapMaybe transModule' ms
        where
          transModule' (n,(_,(optm,_))) =
  	    do m <- optm
  	       return (n,withEnv ([n],env) (transModule m))
          env = foldr ((+++).snd.snd.snd.snd) ([],[]) ms
  -}
  
  writeModule dir (n,U.Module decls) =
      do let path=dir++"/"++modPath n
         ePutStrLn ("Updating: "++path)
         writeFile path ({-printModule-}show m)
    where
      m = U.Module (prefix++decls)
      prefix =
        [ U.Comment magic,
  	U.ImportDecl (U.Import "Haskell.alfa"),
          U.Comment "{-# Alfa hidetypeannots on #-}"]
  
      magic = "-- Automatically converted from Haskell by hs2alfa..."
  
  changedSccs dir g =
      -- A quick hack to avoid retranslating unchanged modules...
      do changed <- map (fst.snd) # filterM moduleChanged (concat g)
         let allsccs = [[m|(f,(m,is))<-scc]|scc<-g]
  	   sccs= [scc|scc<-allsccs,
  		      not.null $
  		      moduleList (subGraph g scc) `intersect` changed]
         return sccs
    where
      moduleChanged (path,(m,_)) =
        newerThan  # getModificationTime path
                  <# getModificationTimeMaybe (dir++"/"++modPath m)
  
  