DrawLex.hs

module DrawLex where
import Monad(join)
import List(groupBy)
import Maybe(mapMaybe,fromMaybe)
import Fudgets
import FudDraw(ulineD')
import GIFAltFile
import OpTypes(eqBy)

import PfePlumbing(Label(..),lblPos,Icons,CertsStatus,addRefPos,refPos,assertionDefLbl)
import TokenTags as C
import HsLexerPass1(nextPos1,Pos(..))
import HsTokens as T
import HLexTagModuleNames
import RefsTypes(merge{-,T(..)-})
import PFE_Certs(CertName,certAttrsPath)
import CertServers(parseAttrs)
import HsName(ModuleName(..))
import TypedIds(NameSpace(..))

-- only the position is significant when locating a Label in a drawing
rootLabel = posLabel rootPos
  where rootPos = Pos (-1) (-1) (-1) -- not a valid file position
posLabel p = Lbl ((TheRest,(p,"")),Nothing)
origLabel orig = Lbl ((TheRest,(refPos orig,"")),Just orig)

fakeLex = labelD rootLabel . vboxlD' 0 . map g . map (expand 1) . take 2500 . lines

drawLex dir icons m colorGctx rs cs na =
    if quickfix
    then
     labelD rootLabel . vboxlD' 0 . map g .
     lines . concatMap (snd.snd)
    else
     labelD rootLabel . vboxlD' 0 .
     map (hboxD' 0 . map tokenD . autoAnnot {-. groupSpace-}) .
     take 2500 . -- Show at most 2500 lines !!
    groupBy sameLine . concatMap split . merge (map addRefPos rs) .
    convModuleNames
  where
    -- split tokens that span several lines:
    split ((t,(Pos n y x,s)),r) =
	[Lbl ((t,(Pos n y' x,l)),r)|(y',l)<-zip [y..] (lines (expand x s))]

    sameLine = eqBy (line.lblPos)

    tokenD lbl@(Lbl((t,(p,s)),r)) = markD . labelD lbl . colorD t . g $ s
      where markD =
              case r of
		Just (_,_,defs) | length defs/=1 -> ulineD' "red"
		_ -> id

            colorD t =
	      case t of
		NestedComment ->
		  case isCertAnnot s of
		    Just cert -> const (drawCertIcon dir icons m cs cert)
		    _ -> fgD C.Comment
		Commentstart  -> fgD C.Comment
		T.Comment     -> fgD C.Comment
		LiterateComment -> fgD C.Comment
		Reservedid    -> fgD Reserved
		Reservedop    -> fgD Reserved
	        Special       -> fgD Reserved
	        Specialid     -> fgD Reserved
		Conid         -> con r
		Qconid        -> con r
		Varsym        -> fgD VarOp
		Qvarsym       -> fgD VarOp
		Consym        -> fgD ConOp
		Qconsym       -> fgD ConOp
		IntLit        -> fgD Lit
		FloatLit      -> fgD Lit
		StringLit     -> fgD Lit
		CharLit       -> fgD Lit
		_             -> id
    fgD = hardAttribD . colorGctx

    con = maybe id (fgD . rcolor)
    rcolor ((_,sp),_,_) = if sp==ValueNames then Con else TCon

    autoAnnot ts = ts++autoannots
      where
        autoannots = map (nestedComment dummyPos.certAnnot) certs
	certs = concatMap (fromMaybe [] . flip lookup na) as
        as = mapMaybe assertionDefLbl ts
        dummyPos = lblPos (last ts)

    certAnnot cert = "{-#cert:"++cert++"#-}"
    nestedComment p s = Lbl ((NestedComment,(p,s)),Nothing)

{-
    groupSpace [] = []
    groupSpace (lbl@(Lbl((t,(p,s)),r)):ts) =
	 if isWhite lbl
	 then case span isWhite ts of
		(ws,ts') -> Lbl((t,(p,s++concatMap str ws)),r):groupSpace ts'
	 else lbl:groupSpace ts
       where
         str (Lbl((_,(_,s)),_)) = s

         isWhite (Lbl((Whitespace,(p,s)),r)) = all isSpace s
         isWhite _ = False
-}

drawCertIcon :: FilePath -> Icons -> ModuleName -> CertsStatus -> CertName ->
	        Drawing lbl Gfx
drawCertIcon dir (sad,icons) m cstatus cert =
    g (fileGfxAlt certIcon (certAttrsPath m cert dir) sad)
  where
    certIcon s =
     case (`lookup` icons) =<< lookup "type" (parseAttrs s) of
       Just cicons -> Right (cstatusIcon cicons (join (lookup cert cstatus)))
       _ -> Left "bad cert/unknown cert type"

certIcon (sad,icons) (cert,(Just attrs,cstatus)) =
  case (`lookup` icons) =<< lookup "type" attrs of
    Just icons -> cstatusIcon icons cstatus
    _ -> sad
certIcon (sad,_) _ = sad

cstatusIcon (valid,invalid,unknown) cstatus =
  case cstatus of
    Just (isvalid,_) -> if isvalid then valid else invalid
    _ -> unknown

-- isCertAnnot :: Monad m => String -> m CertName
isCertAnnot s =
  do '{':'-':'#':'c':'e':'r':'t':':':r <- return s
     '}':'-':'#':f <- return (reverse r)
     return (reverse f)

{- Why use "case" when you can use "do"? :-)
isCertAnnot s =
  case s of
    '{':'-':'#':'c':'e':'r':'t':':':r ->
        case reverse r of
          '}':'-':'#':f -> Just (reverse f)
          _ -> Nothing
    _ -> Nothing
-}

expand x "" = ""
expand x (c:s) =
    case c of
      '\t' -> replicate (x'-x) ' '++expand x' s
      _ -> c:expand x' s
  where Pos _ _ x' = nextPos1 (Pos 0 1 x) c

quickfix = argFlag "quickfix" False