content: module PfeBrowserF(mainF) where
  import Prelude hiding (putStr,putStrLn,print,readFile,writeFile,ioError,catch,readIO)
  import Monad(unless,mplus,when,filterM)
  import Maybe(fromMaybe,mapMaybe,isJust)
  import List(find,(\\),nub)
  import AllFudgets as Fud hiding (getModificationTime)
  import ContribFudgets hiding (lift)
  
  import FudgetIOMonad1
  import PfePlumbing
  import PfeBrowserMonad
  import IdInfo
  import PfeBrowserGUI
  import CertAttrsEditorF
  import PfeBrowserMenu as M
  import PfeBrowserCerts
  import CertServerF
  import CertCmd
  import AuxWindowsF
  import ImageGraphics(gifFile)
  import FudExtras(longTextPopupF)
  
  import HsModule(ModuleName(..),hsModName,{-,HsModuleI-})
  import HsTokens as T
  import PropPosSyntax(getHSName,SrcLoc(..))
  import TiDecorate(no_use)
  import TI(Typing(..),envFrom,topName,HsIdentI(..))
  import PNT(PNT(..))
  import TypedIds(namespace,isClassOrType)
  import UniqueNames as UN(OptSrcLoc(N),optOrigModule)
  import HasBaseName(getBaseName)
  
  import PFE0(getModuleInfixes,setBatchMode,checkProject,ppFlags,
  	    withProjectDir,epput,
  	    updateModuleGraph,findNode,projectDir,getCurrentModuleGraph)
  import PFE2(getModuleExports)
  import PFE3(parseSourceFile'')
  import ScopeModule(checkRefs)
  import PFE4(exTypeCheck)
  import Pfe2Cmds(ppExports)
  import Pfe4Cmds(ppIface,moduleInterface)
  import PFE_Certs
  import CertServers(printAttrs)
  
  import PPU(pp,ppi,ppu,withPPEnv,($$),(<>),(<+>),vcat)
  import DrawDoc(drawDoc)
  import DrawError
  import DrawLex(origLabel,certIcon)
  import FudDraw(ulinkD)
  import MT(lift)
  import MUtils
  import AbstractIO hiding (getEnv)
  import FileUtils(updateFile)
  import SimpleGraphs(reverseGraph,neighbours)
  import StatusIndicator(statusF,Status(..))
  
  -- Debuging
  --import IOExts(trace)
  
  --- Plumbing -------------------------------------------------------------------
  
  mainF opts pdir servers =
      loopOnlyF $ titleShellF' (setSizing Static) myversion pfeBrowserF
    where
      pfeBrowserF = pfeF opts >==< guiF
  
      -- @ guiF : the graphical user interface fudget of the PFE browser
      guiF :: F Out In
      TagF guiF dispatch tags =
  	mapTF vBoxF $
  	    (mapTF hBoxF (pfeMenuBarTF>&<statusTF) >&< infoWindowsTF)
  	>&< compTagF (hSplitF' aLeft) graphDispTF moduleDispTF
  	>&< (popupsTF >&< certServerTF)
  
      toTitle = Left
      (_toMenuBar:&:toStatus:&:_toInfoWindows):&:(toGraph:&:toModuleDisp)
       :&:(toPopups:&:toCertServer)=
  	extend Right tags
      toMessagePopup:&:toNewCertPopup:&:(toCertAttrsEditors:&:toTextEditor) = toPopups
  
      pfeMenuBarTF = tagF fromMenuBar (pfeMenuBarF types)
        where
          types = [serverName s|s<-servers,
  		              lookup "has_sequent" (serverAttrs s)/=Just "no"]
  
      statusTF = tagF (const done)
                      (spacer1F centerS $ {-"Status:" `labLeftOfF`-} statusF)
  
      popupsTF = messagePopupTF >&< newCertPopupTF >&<
  	       (certAttrsEditorsTF >&< textEditorPopupTF)
        where
  	messagePopupTF = tagF fromMessagePopup (snd>^=<longTextPopupF)
  	newCertPopupTF = tagF fromNewCertPopup newCertPopupF
  	certAttrsEditorsTF = tagF fromCertAttrsEditor dynCertAttrsEditorPopupsF
  	textEditorPopupTF = tagF fromTextEditor textEditorPopupF
  
      graphDispTF = tagF fromGraph graphDispF
      certServerTF = tagF fromCertServer certServerF -- actually not a GUI part...
  
      toNodeInfo:&:(_toSource:&:_toRefs) = toModuleDisp
      moduleDispTF =
  	mapTF vBoxF $     tagF fromNodeInfo nodeInfoF
  		      >&< compTagF (vSplitF' aBottom)
  				   (tagF fromSource sourceDispF)
  				   (tagF fromRefs refDispF)
  
      infoWindowsTF = tagF fromInfoWindows $
  		    spacer1F (noStretchS False True `compS` rightS) $
  		    auxGfxWindowsF myname
  
      fromGraph = newNode
      fromNodeInfo = either newModuleLbl newFile
      fromRefs = infoPick Nothing
      fromMessagePopup _ = done
  
      fromInfoWindows = either popupInfoWindow infoPick'
        where infoPick' (w,infolbl) = infoPick (Just w) infolbl
  
      infoPick optw infolbl =
        case infolbl of
  	CertLbl cert -> clearRefs >> changeHilite [] >> updCertInfo cert
          DefLbl (HsCon (PNT pn sp _)) -> goto (HsCon pn,sp)
          DefLbl (HsVar (PNT pn sp _)) -> goto (HsVar pn,sp)
  	SrcLocLbl (path,pos) -> newFile path >> gotoLabel (posLabel pos)
            where gotoLabel lbl = do pfePut . toSource . mkvis $ lbl
  			           changeHilite [lbl]
          ModuleLbl m -> newModuleLbl (m,Nothing)
  	CertCmd cmd@(ValidateCert qcert) ->
  	    do putCertServer cmd
  	       vcert <- certDisplay # getStBr
  	       when (vcert==Just qcert) $ showQCertInfo qcert
  	CertCmd cmd ->
  	    do maybe done close optw
  	       putCertServer cmd
  	  where
  	    close w = popupInfoWindow (w,False)
  
  	CreateCert ca -> newCertPopup ca
  	CertEdit e -> pfePut (toCertAttrsEditors (Right e))
  	CertShowText txt -> pfePut . toMessagePopup . map backspace . lines $ txt
  	ShowErrorMsg gfx -> popupErrorMsg gfx
  
      newCertPopup ca =
        do cicons <- certIcons # getStBr
  	 clearRefs
  	 pfePut (toNewCertPopup (cicons,ca))
  
      putCertServer cmd =
  	do cmds <- certInProgress # getStBr
  	   setInProgress (cmds++[cmd])
  	   if null cmds then doCertServer shellcmd else notnow
        where
  	shellcmd = shellCmd cmd
  	notnow = certCmdMsg "Command added to queue" shellcmd
  
      -- pre: no command in progress
      doCertServer shellcmd =
  	do certCmdMsg "Sent certificate server command" shellcmd
  	   pfePut (toCertServer shellcmd)
  
      certCmdMsg msg cmd =
        do cnt <- length . certInProgress # getStBr
           pfePut $ toRefs $ linesD $
  		    [g $ msg++":", g cmd]
  		    ++(if cnt>0
  		       then [g $ "Number of commands in queue: "++show cnt]
  		       else [])
  
      fromNewCertPopup (ty,(cert,concl)) =
        if null cert || null concl
        then popupMsg "Fill in both a certificate name and a conclusion when creating a new certificate!"
        else do m <- modname # getStBr
  	      let qcert = QCertName m cert
  		  cmd = CertCmd.NewCert ty qcert concl
  	      putCertServer cmd
  	      dcert <- certDisplay # getStBr
  	      when (dcert==Just qcert) $ showQCertInfo qcert
  
      fromCertAttrsEditor (ctype,(cname,userattrs)) =
        do Just dir <- projectDir
  	 m <- modname # getStBr
  	 (_,(Just oldattrs,_)) <- certInfo m cname
  	 let newattrs = updateAttrs oldattrs userattrs
  	 updateFile (certAttrsPath m cname dir) (printAttrs newattrs)
  	 infoPick Nothing (CertLbl cname) -- hmm
       where
  	updateAttrs oldattrs newattrs =
  	    map replace oldattrs++addedattrs -- preserve the order!
  	  where
  	    addedattrs = filter added newattrs
  	    added (n,_) = n `notElem` map fst oldattrs
  	    replace (name,old) = (name,fromMaybe old (lookup name newattrs))
  
      fromTextEditor ((_,Just src),src') =
  	if src'/=src
  	then do srcpath <- fst . modnode # getStBr
  		-- This assumes that the editor window is modal, so that
  		-- the current node still is the same!!
  		writeFile srcpath src'
  		reloadModule
  	else done
      fromMenuBar msg = 
        case msg of
  	File fcmd -> fileCmd fcmd
  	View vcmd -> viewCmd vcmd
  	Windows wcmd -> windowCmd wcmd
  	Cert ccmd -> certCmd ccmd
  	_ -> done -- !!
        where
  	fileCmd Quit = pfeQuit
  	fileCmd ReloadModule = reloadProject
  	fileCmd EditModule = editModule
  
  	viewCmd vcmd = do updStBr $ \ st->st{viewMode=vcmd}
  			  optGetTypes
  
  	windowCmd (WindowCmd w up) =
  	    pfePut (toInfoWindows (w,Left up)) --up is False or True
  
  	certCmd certcmd =
  	  case certcmd of
  	    M.NewCert -> whenInModuleM $ newCertPopup ("","")
  	    M.NewAll certtype -> whenInModuleM $ newAll certtype
  	    M.TodoCert -> putCertServer CertCmd.TodoCert
  	    RevalidateAllQuick -> revalidateAll >> reloadModule
  	    ValidateAll -> validateAll
  	    _ -> done -- !!
  
          newAll ty =
            do m <- modname # getStBr
               putCertServer $ CertCmd.NewCertAll ty (pp m)
  
          validateAll =
            do m <- modname # getStBr
  	     let qcert = QCertName m
  		 validateOne = putCertServer . ValidateCert . qcert . fst
  	     mapM_ validateOne. certs =<< getStBr
  
  	editModule =
  	   do n <- modnode # getStBr
  	      unless (isNoModule n) $
  		do let srcpath = fst n
  		       mname = fst (snd n)
  		       prompt = "Edit "++pp mname++" in "++srcpath
  		   src <- readFile srcpath
  		   pfePut (toTextEditor (Just prompt,Just src))
  
      fromCertServer (ok,output) =
        do cmds <- certInProgress # getStBr
  	 let cmds' = drop 1 cmds
  	 setInProgress cmds'
  	 if null cmds'
  	    then do clearRefs
  		    changeHilite []
  		    {-when ok-}
  		    reloadModule
              else doCertServer (shellCmd (head cmds'))
  	 unless (null output) (route cmds . map stripEither $ output)
        where
  	route (ValidateCert qcert:_) msg =
  	    certCmdMsg (ppqcert qcert) (last msg)
  	route _ msg =
  	  if ok && length msg <= 3
  	  then pfePut . toRefs . linesD . map g $ msg
  	  else pfePut $ toMessagePopup msg
  
      --- Initialization and main loop -------------------------------------------
  
      --pfeF o = nullF
      pfeF :: Opts -> PfeF
      pfeF = runFIOM . runPfeFM pfeFM
  
      pfeFM :: PfeFM ()
      pfeFM =
  	do g <- getCurrentModuleGraph
  	   icons <- getCertIcons servers
  	   sadicon <- getIcon (gifFile (badCertIconPath pdir))
  	   setStBr St{modnode=noModuleNode,viewMode=view0,mrefs=[], hilbls=[],
  		     types=Nothing,certs=[],revgraph=reverseGraph (map snd g),
  		     certDisplay=Nothing,certInProgress=[],
  		     certServers=servers,certIcons=icons,sadIcon=sadicon}
  	   pfePut (toGraph g)
  	   putInfoWindow (CertTypes,drawCertTypes (zip servers icons))
  	   pfePut (toCertAttrsEditors (Left servers))
  	   setBatchMode False
  	   pfeloop
        where	  
  	pfeloop :: PfeFM ()
  	pfeloop =
  	  do (dispatch =<< pfeGet) `catch` stdHandler
  	     pfeloop
  
  	getCertIcons :: CertServers -> PfeFM CertIcons
  	getCertIcons servers = mapM getCertIcon servers
  	getCertIcon certServer =
  	  do let dir = serverDir certServer
  		 certtype = serverName certServer
  		 iconsrc status = gifFile (dir++"/"++status++".gif")
  	     valid   <- getIcon (iconsrc "valid")
  	     invalid <- getIcon (iconsrc "invalid")
  	     unknown <- getIcon (iconsrc "unknown")
  	     return (certtype,(valid,invalid,unknown))
  
  	getIcon = lift . xrequestFIOM . convToPixmapK
  
  	drawCertTypes = htableD hdrs . concatMap certD
  	  where
  	    hdrs = ["Icon","Type","Description"]
  	    certD (server,(ty,(icon,_,_))) = [g icon,g ty,g descr]
  	      where
  		descr = fromMaybe "(Descrption missing)" $
  			lookup "description" (serverAttrs server)
  
      typeErrorHandler err =
        do --setNoTypes
  	 pfePut $ toRefs $ fgD "red" $ g "Type error!"
  	 setStatus (Typing,InError)
           --o <- ppFlags
  	 m <- modname # getStBr
           popupErrorMsg (fontD ppfont (drawTypeError m err))
  	 epput err
  	 
  {-
      setNoTypes = do updStBr $ \ st->st{viewMode=Hyper}
  		    putStrLn "Switching off type info"
  		    pfePut (toMenuBar (View Hyper))
  -}
      stdHandler err =
  	do epput msg
  	   -- popupMsg msg
  	   unless (null msg) $ popupErrorMsg (msgGfx msg)
  
        where msg = ioeGetErrorString err
  
      popupErrorMsg gfx =
  	do putInfoWindow (ErrorMsg,gfx)
  	   popupInfoWindow (ErrorMsg,True)
  
      clearErrorMsg = putInfoWindow (ErrorMsg,blankD 10)
  
      setStatus = pfePut . toStatus
  
      resetStatus = sequence_ [setStatus (l,Unknown)|l<-[minBound..maxBound]]
  
      whenInModuleM = unlessM (isNoModule.modnode # getStBr)
  
  
      --- Reactions and auxiliary functions --------------------------------------
  
      reloadProject =
  	-- skip reload if there is no project, or no module is selected
  	whenInModuleM $ reloadGraph >> reloadModule
        where
  	reloadGraph =
  	  do updateModuleGraph
  	     -- should also check for added/removed files and update graphDispF
  	     updModNode . modname =<< getStBr
  
      updModNode m =
        do g <- getCurrentModuleGraph
  	 node <- findNode m
  	 updStBr $ \st->st{revgraph=reverseGraph (map snd g),modnode=node}
  	 return node
  
      reloadModule =
        whenInModuleM $
  	do maybe done showQCertInfo . certDisplay =<< getStBr
  	   newNode . modnode =<< getStBr
  
      {-+ #newNode#: load and display a new module, after the user has entered or
  	 clicked on a module name or a file name. -}
      newNode node@(path,_) =
        withWaitCursor $
        do resetStatus
  	 clearErrorMsg
  	 setStatus (Syntax,InProgress)
           dir <- checkProject
  	 --pfePut (toSource (Left ("","",[]))) -- empty window to scroll to top
  	 r <- try (parseSourceFile'' path)
  	 case r of
  	   Left err -> badNode dir err
  	   Right (ts,((wm,ast),refs)) ->
  	    do node@(_,(m,_)) <- updModNode (getBaseName (hsModName ast)) --updates revgraph
  	       let --refs =simplifyRefsTypes' rs
  		   asserts = assertions ast -- :: [(PNT,AssertionI PNT)]
  		   certs_annot = mapMaybe isCertToken ts -- :: [CertName]
  		   isCert cert = doesFileExist (certAttrsPath m cert dir)
  	       certs_existing <- filterM isCert . fromMaybe [] =<<
  			    maybeM (getDirectoryContents (certModuleDir m dir))
  	       let certs_noannot = certs_existing \\ certs_annot
  		   certs = certs_annot++certs_noannot
  	       certsStatus <- zip certs # quickCertsStatus m certs dir
  	       certsInfo <-
  		  let replace = zipWith replace1 certsStatus
  		      replace1 (_,s) (c,(a,s0)) = (c,(a,s))
  		  in replace # mapM (certInfo m) certs
  	       let conccert (cert,(attrs,_)) =
                       flip (,) cert # (lookup "conc" =<< attrs)
                     na = collectByFst .
  			mapMaybe conccert .
  			filter ((`elem` certs_noannot).fst) $
  			certsInfo
  	       updStBr $ \st->st{mrefs=refs,hilbls=[],types=Nothing,certs=certsInfo}
  	       e <- getModuleExports m
  	       -- To keep the displays consistent with the internal state,
  	       -- output operations should come after all operations that can fail!
  	       setStatus (Syntax,Good)
  	       setStatus (Scoping,InProgress)
  	       scope_ok <- showScopeErrors refs
  	       setStatus (Scoping,if scope_ok then Good else InError)
  	       importedby <- flip neighbours m . revgraph # getStBr
  	       pfePut (toNodeInfo (Left (node,importedby)))
  	       cicons <- icons # getStBr
  	       pfePut (toSource (Left (dir,cicons,node,ts,refs,certsStatus,na)))
  	       o <- ppFlags
  	       putInfoWindow (Exports,ppo o (ppExports m e))
  	       putInfoWindow (Interface,ppMsgGfx o clickToActivate)
  	       putInfoWindow (Pretty,ppo o ast)
  	       putInfoWindow (Evidence,evidenceGfx m dir cicons certsInfo asserts)
  	       pfePut (toTitle (myname++": "++pp m))
  	       when scope_ok optGetTypes
        where
  	{-+
  	Rather than aborting newNode (and potentially leaving the history buttons
  	in an incosistent state) on errors, display an empty window and continue...
  	-}
  	badNode dir err =
  	  do o <- ppFlags
  	     s <- fromMaybe [] # maybeM (readFile path)
  	     updStBr $ \st->st{modnode=node}
  	     pfePut (toRefs (ppMsgGfx o (ioeGetErrorString err)))
  	     pfePut (toNodeInfo (Left (node,[])))
  	     pfePut (toSource (showsrctext s))
  	     setStatus (Syntax,InError)
  	     putInfoWindow (Exports,blankD 10)
  	     putInfoWindow (Interface,blankD 10)
  	     putInfoWindow (Pretty,blankD 10)
  	     putInfoWindow (Evidence,blankD 10)
  	     pfePut (toTitle (myname++": "++path))
  
  	showScopeErrors refs =
  	    do if ok
  		 then clearRefs
  		 else do o <- ppFlags
  			 pfePut (toRefs (gfx o))
  	       return ok
  	    where
                ok = null errs
  	      errs = checkRefs refs
  	      errcnt = length errs
  
  	      gfx o =
                  labelD (ShowErrorMsg (fontD ppfont (drawScopeErrors errs)))
  		       (ulinkD (g msg))
  
  	      msg = if errcnt==1
  		    then "One scoping error"
  		    else show errcnt++" scoping errors"
  
      {-+ #newModule#: load and display a new module after the user has entered
  	or clicked on a module name. -}
      newModule :: ModuleName ->PfeFM ()
      newModule m = newNode =<< findNode m
  
      newModuleLbl (m',optlbl) =
        do n@(_,(m,_)) <- modnode # getStBr
  	 when (isNoModule n || m'/=m) $ newModule m'
  	 maybe done gotoLabel optlbl
        where
  	gotoLabel lbl = do pfePut . toSource . mkvis $ lbl
  			   showInfo lbl
  
      {-+ #newFile#: load and display a new module after the user has entered or 
  	clicked on a file name. -}
      newFile :: FilePath ->PfeFM ()
      newFile path =
        do (oldpath,_) <- modnode # getStBr
  	 when (path/=oldpath) $
  	   do updateModuleGraph
  	      g <- getCurrentModuleGraph
  	      case [node|node@(path',_)<-g,path'==path] of
  		[node] -> newNode node
  		_ -> fail ("File not part of this project:"++path)
  
      {-
      goto o@(_,r) =
        case r of 
  	Left (s,n) ->
  	  do let m' = Module s
  	     m <- modname # getStBr
  	     unless (m'==m) $ newModule m'
  	     gotoLocal o
  	_ -> gotoLocal o
      -}
  
      goto o@(r,_) =
  	  do let optm' = optOrigModule r
  	     m <- modname # getStBr
  	     case optm' of
  	       Just m'| m'/=m -> newModule m'
  	       _ -> done
  	     gotoLocal o
  
      gotoLocal (o,sp) =
        do st <- getStBr
  	 case [r|r@((d,_),_,[(o',sp')])<-mrefs st,
  		 isDef d,o'==o,namespace sp'==namespace sp]
  	   of orig:_ -> do let lbl = origLabel orig
  			   pfePut (toSource (mkvis lbl))
  			   rememberLbl lbl
  			   showInfo lbl
  	      _ -> putStrLn $ "Didn't find def of "++show o
  
      rememberLbl lbl = 
  	do m <- modname # getStBr
  	   pfePut (toNodeInfo (Right (m,lbl)))
  
      followLink lbl def = rememberLbl lbl >> goto def
  
      changeHilite new =
        do old <- hilbls # getStBr
  	 pfePut (toSource (hilite (old\\new) (new\\old)))
  	 updStBr $ \st->st{hilbls=new}
  
      getIdInfo lbl@(Lbl token) =
        do refs <- mrefs # getStBr
  	 infixes <- getModuleInfixes
  	 path <- fst . modnode # getStBr
  	 let p = (path,lblPos lbl)
  	     (occurences,optdef,refinfo) = idInfo refs infixes token
  	 return ((occurences,optdef,concatMap msglines refinfo),p)
  
      fromSource (Just (Button 1),lbl@(Lbl ((ModuleName,(_,mn)),_))) =
  	newModule (PlainModule mn) -- !!!
      fromSource (Just button,lbl@(Lbl token)) =
  	case button of
  	  Button 1 -> case isCertTokenRef token of
  			Just cert -> changeHilite [lbl] >> updCertInfo cert
  			_ -> do info@((_,optdef,_),_) <- getIdInfo lbl
  				case optdef of
  				  Nothing -> done
  				  Just def ->
  				    if isDefLbl lbl
  				    then showInfo' lbl info
  				    else followLink lbl def
  	  Button 2 -> showInfo lbl
  	  Button 3 -> do ((occurences,_,refinfo),_) <- getIdInfo lbl
  			 let cnt=length occurences
  			     msg=if cnt>0
  				 then ["Highlighted all "++show cnt++
  					" occurences in this module"]
  				 else []
  			 changeHilite (map posLabel occurences)
  			 pfePut (toRefs (linesD (map g (refinfo++msg))))
  	  _ -> done
      fromSource (Nothing,lbl) =
  	ifM (isLink lbl)
  	    (pfePut (toSource setlinkcursor))
  	    (pfePut (toSource setnormalcursor))
        where
  	isLink (Lbl ((ModuleName,(_,mn)),_)) = return True
  	isLink lbl = 
  	  if isDefLbl lbl
  	  then return False
  	  else do info@((_,optdef,_),_) <- getIdInfo lbl
  		  return (isJust optdef)
  
      updCertInfo cert = showCertInfo cert >> updCertIcons cert
  
      updCertIcons cert = whenM (statusChange cert) reloadModule
         -- TODO: efficient icon updates in the source display and evidence window
  
      showInfo lbl = showInfo' lbl =<< getIdInfo lbl
  
      showInfo' lbl ((_,def,refinfo),p) =
  	do --optGetTypes
  	   tinfo <- maybeD (optGetType p) def
  	   ainfo <- maybeD getAssertionInfo def
  	   pfePut (toRefs (linesD (map g refinfo++ainfo++tinfo)))
  	   changeHilite (if isJust def then [lbl] else [])
        where
  	maybeD = maybe (return [])
  
  	optGetType p o = maybe (return []) (getType p o) . types =<< getStBr
  
  	getType p (qn,k) types =
  	  do --print (k,qn)
  	     m <- modname # getStBr
  	     let env = modtypes m types
  	     o <- ppFlags
  	     --print (let xs:>:_ = unzipTyped mt in xs)
  	     return [typeInfo o env k p qn]
  
  	typeInfo ppopts (mt,env) k p qn =
  	    if isClassOrType k
  	    then kinfo qn (fst env)
  	    else tinfo (snd (no_use env)) mt p qn
  	 where
  	    kinfo qn = optpp . lookup qn . convTEnv (ppi.fst)
  
  	    optpp = maybe (Fud.g "No type/kind info available") (ppo ppopts)
  
  	    tinfo env mt (path,lexpos) qn =
  		optpp (find' mt `mplus` lookup qn env')
  	      where env' = convTEnv (ppi.fst) (env++mt)
  		    qn' = getHSName qn
  		    find' = fmap pp_use . find (pos.name)
  		    name (i:>:_) = getHSName i
  		    pos (PNT pn _ (N (Just (SrcLoc f _ lin col)))) =
  		      pn==qn' && f==path && col==column lexpos && lin==line lexpos
  		    pos i = False
  		    pp_use (_:>:(gen,opti)) =
  		      case opti of
  			Just inst -> "Generally:"<+>gen<>","$$"Here:"<+>inst
  			_ -> ppi gen
  
  		    pntpos (PNT _ _ (N p)) = p
  
  	convTEnv f env = [(bn i,f info)|i:>:info<-env]
  	  where
  	    bn = fmap orig -- . getHSName
  	    orig (PNT n _ _) = n
  
  	modtypes m pfe4info = (snd (envFrom tm),(concat kenvs,concat tenvs))
  	  where
  	    Just (_,((_,tm):_,_)) = lookup m (pfe4info::TInfo)
  	    (kenvs,tenvs) = unzip [env|(_,(_,(_,(_,env))))<-pfe4info]
  
      optGetTypes =
        do st <- getStBr
  	 when (viewMode st==Typed &&
                 not (isNoModule (modnode st) || haveTypes st))
  	      (retypeCheck (modname st))
        where
          retypeCheck m =
  	     withWaitMsg (g "Type checking...") $
  	     do setStatus (Typing,InProgress)
                  opttypes <- exTypeCheck (Just [m])
  		case opttypes of
  		  Left err -> typeErrorHandler err
  		  Right types ->
  		    do mIface <- moduleInterface m -- calls typeCheck again ==> slow!!
  		       setStatus (Typing,Good)
  		       o <- ppFlags
  		       putInfoWindow (Interface,ppo o (ppIface mIface))
  		       updStBr $ \st->st{types=Just types}
  
      clearRefs = pfePut (toRefs (blankD 10))
  
      popupMsg = pfePut . toMessagePopup . msglines
  
      withWaitMsg msg cmd =
        do pfePut (toRefs msg)
  	 tryThen (withWaitCursor cmd) $ clearRefs
  
  setInProgress cmds =
      do updStBr $ \ st -> st{certInProgress=cmds}
         o <- ppFlags
         putInfoWindow (PendingCmds,ppo o (vcat cmds))
  
  ppMsgGfx o = msgGfx . ppu o
  msgGfx = linesD . map g . msglines
  --msgGfx = vboxlD' 0 . map (atomicD . expandTabs 8)
  
  ppo ppopts = ppo' ppopts
  ppo' (_,ppopts) = fontD ppfont . drawDoc . withPPEnv ppopts . ppi
  
  msglines = map (expandTabs 8) . lines
  
  clickToActivate = 
  --  "(To activate type checker: click with the middle mouse button on an identifier)"
    "(To activate type checker: select Type Info from the View menu)"
  
  ---
  {-
  instance CatchIO e m => CatchIO e (WithState s m) where
    stm `catch` h =  do s <- getSt
  		      r <- lift $ try (withStS s stm)
  		      case r of
  			Left err -> h err
  			Right (ans,s') -> setSt_ s' >> return ans
    ioError = lift . ioError
  -}
  
  --
  ppfont = argKey "ppfont" refFont
  