PfeBrowserGUI.hs

module PfeBrowserGUI(module PfeBrowserGUI,posLabel) where
import List(groupBy,sortBy)
import Maybe(isNothing)
--import Char(isSpace)

import AllFudgets
import FudExtras(popupMenuF',staticHyperGraphicsF')
import ContribFudgets(menuIcon,item,itemValue)--menuBarF,delayedSubMenuItem,idT,cmdItem
import HyperGraphicsF2
import TreeBrowser as B(treeBrowserF',Tree(..))
import HistoryButtonsF
import ListUtil(chopList,breakAt,mapFst)

import PfePlumbing
import PfeBrowserColors as C
import DrawLex(drawLex,fakeLex,posLabel,rootLabel,isCertAnnot)

import HsLexerPass1(lexerPass0)
import HsTokens as T
import HsName(ModuleName(..),parseModuleName)

import OpTypes(cmpBy)
import PrettyPrint(pp,(<+>))
import MUtils(apSnd)

textEditorPopupF = 
    inputPopupF "Editor" (spF $ oldScrollF True (500,600) inputEditorF) Nothing
  where spF = spacer1F (noStretchS False False)

newCertPopupF :: F ToNewCertPopup FromNewCertPopup
newCertPopupF =
    snd>^=<inputPopupF title newCertF Nothing >=^< pre
  where
    title = "Create a new certificate"
    pre inp = (Just title,Just inp)

newCertF = tableF 2 (typeF `inputPairF` (nameF `inputPairF` conclF))
  where
    typeF = labelF "Type" >*<
              (inputChange>^=<dynF nullLF
               >=^< Left . radioButtonsF>=^^<idempotSP>=^<map certTypeItem)
    radioButtonsF [] = labelF "No certificate types available?!"
    radioButtonsF items@(item1:_) =
      radioGroupF [(itemValue item,item)|item<-items] (itemValue item1)

    nameF = labelF "Name" >*< stringF
    conclF = labelF "Conclusion" >*< stringF

    certTypeItem (cert,(icon,_,_)) = item cert (hboxD [g icon,g cert])

graphDispF :: F ToGraph FromGraph
graphDispF =
    mapFilterSP leaf>^^=<
    vScrollF (treeBrowserF' g0)>=^<graphTree.sortBy (cmpBy (fst.snd))
  where
    g0 = graphTree []
    leaf (B.Leaf l) = Just (itemValue l)
    leaf _ = Nothing

    graphTree g =
	Node "Module Graph" [Node "Files" (filepaths2trees g),
			     Node "Modules" (map mitem g)]
      where
	mitem n@((_,(m,_))) = B.Leaf (item n (pp m))

    filepaths2trees = list2trees . map withpath
      where
	list2trees = map tree . groupBy eqHead . sortBy (cmpBy fst)

	--tree ([]:_) = ??
	tree [([f],p)] = B.Leaf (item p f)
	tree ((x:xs,p):ys) = Node x (list2trees ((xs,p):mapFst tail ys))

	eqHead (x:xs,_) (y:ys,_) = x==y
	eqHead ([],_) ([],_) = True
	eqHead _ _ = False

	withpath n@(path,_) = (chopList (breakAt '/') path,n)

refDispF :: F ToRefs InfoLbl
refDispF = scrollF (staticHyperGraphicsF' pm initD)
  where pm = setSizing Dynamic . setFont refFont
        initD = padD 20 $ g $
		 "Welcome to the "++myversion++"!"

data ModPos = MP ModuleName (Maybe Label) deriving (Eq)

instance Graphic ModPos where
  measureGraphicK (MP m optpos) =
      measureGraphicK (pp $ m<+>fmap (line.lblPos) optpos)

nodeInfoF :: F ToNodeInfo FromNodeInfo
nodeInfoF =
    --simpleGroupF [] $
    vBoxF (fileF>*<hBoxF (historyF>*<nodeF))
  where
      -- Input is: ((f,(n,is)),es)+Pos

    fileF = Right >^=< ldispF  "File:" >=^< fst.fst >=^^< filterLeftSP

    historyF =
        post >^=<
        loopThroughRightF (absF ignore0)
		          (historyButtonsF{- >==< teeF show "history: "-})
        >=^< mpos
      where
	mpos = mapEither mpos1 mpos2
        mpos1 ((f,(n,is)),es) = MP n Nothing
	mpos2 (m,p) = MP m (Just p)
	post (MP m optpos) = Left (m,optpos)

	ignore0 = getSP $ either repeat (either makehistory (const ignore0))

	repeat cur = putSP (Right cur) $ ignore cur
	makehistory new = putSP (Left (Left new)) $ ignore new
	replace new = putSP (Left (Right new)) $ ignore new

	ignore cur@(MP m op) = getSP $ either repeat (either newmod updpos)
          where
	    newmod new@(MP m' Nothing) | m'==m = ignore cur
	    newmod new = makehistory new

	    updpos new | new==cur = ignore cur
	    updpos new@(MP m' _) | m'==m && isNothing op = replace new
	    updpos new = makehistory new

    nodeF = (moduleF>*<dynImportMenusF)  >=^^< filterLeftSP
    moduleF = post . parseModuleName >^=< ldispF "Module:" >=^< pp.fst.snd.fst
      where post m = Left (m,Nothing)

    ldispF l = l `labLeftOfF` strF
      where strF = stringInputF --' (setSizing Dynamic)

    dynImportMenusF =
       dynModuleMenuF "Imports" >=^< snd.snd.fst
        >*<dynModuleMenuF "Imported By" >=^< snd
 
    dynModuleMenuF lbl = popupMenuF' 1 [] (menuLblF lbl)>=^<pre
      where pre ms = Left [((m,Nothing),pp m)|m<-take 30 ms]
			   -- !! no indication if menu is truncated

    menuLblF lbl = labelF' pm (hboxcD [g lbl,g menuIcon])
      where pm = setBorderWidth 1 . setBgColor paperColor

    --fud1>|<fud2 = stripEither>^=<prodF fud1 fud2

sourceDispF :: F ToSource FromSource
sourceDispF =
    wCreateGCtx rootGCtx (gcFontA sourceFont) $ \ gctx ->
    loadColorsF gctx sourceDispF'

sourceDispF' colgc =
    scrollF (mousePointSP>^^=<hyperGraphicsF2' pm init)>=^<either replace id
  where
    pm = setFont sourceFont . setGfxEventMask [GfxButtonMask,GfxMotionMask]
    init = drawLex undefined undefined undefined colgc [] [] [] empty
    empty = lexerPass0 (replicate 24 '\n'++replicate 80 ' ') -- for initial size
    replace (dir,icons,(path,(m,_)),ts,rs,cs,na) =
      replaceGfx rootLabel $ drawLex dir icons m colgc rs cs na ts

    mousePointSP = idempotSP -==- mapFilterSP label
      where
        label event =
          do (lbl,_):_ <- gfxEventPaths event
	     case event of
	       GfxButtonEvent {gfxType=Pressed,gfxButton=b} -> Just (Just b,lbl)
	       GfxMotionEvent {} -> Just (Nothing,lbl)
	       _ -> Nothing

highlightGfxs off on = ChangeGfx $ change off False++change on True
  where change paths on = [(path,(on,Nothing))|path<-paths]

hilite off on = Right (highlightGfxs off on)
mkvis lbl = Right (ShowGfx lbl (Nothing,Nothing))
setwaitcursor =  Right (ChangeGfxFontCursor 150)
setlinkcursor =  Right (ChangeGfxFontCursor 60)
setnormalcursor = Right (ChangeGfxCursor cursorNone)
showsrctext = Right . replaceGfx rootLabel . fakeLex

isCertTokenRef = isCertToken . fst
isCertToken token =
  do (NestedComment,(_,s)) <- return token
     isCertAnnot s


-- Moved file path definitions to ../../property/pfe/PFE_Certs.hs

sourceFont = argKey "sourcefont" defaultFont
refFont = argKey "reffont" defaultFont