Highlight.hs

{-OPTIONS_GHC -XFlexibleInstances -XFlexibleContexts -}
module Language.Haskell.FreeTheorems.Variations.PolySeq.Highlight (highlight,highlightWith) where

import Text.XHtml
import Text.PrettyPrint.HughesPJ hiding (char,style)
import Text.Parsec.String(Parser)
--import Text.Parsec.Token as P
import Text.Parsec.Combinator(manyTill, lookAhead, eof)
import Text.Parsec.Prim(ParsecT,Stream,(<|>),try,parse,getParserState)
import Text.ParserCombinators.Parsec.Char(oneOf,char,anyChar,string)
--import Text.ParserCombinators.Parsec.Language(emptyDef)
import Text.Parsec

import Language.Haskell.FreeTheorems.Variations.PolySeq.Debug

--traceM = traceM_toShell
--traceM = traceM_ignore
--traceState = do state <- getParserState;
--                traceM ("with the Parser state " ++ show (stateInput state) ++ "\n");	

-- data What = Keyword String
-- 	  | BottomReflectionRestriction

-- data HighLightMode  = Color String
--  		    | BgColor String

makeHglt :: String -> (Html -> Html)
makeHglt mode = thespan![thestyle (mode)]


highlightWith :: String -> String -> Html
highlightWith hgltMode str =
    let hglt = makeHglt hgltMode
        res = parse (highlt hglt) "" str in
    case res of
      Left err   -> toHtml (show err)
      Right html -> html

highlight :: String -> Html
highlight = highlightWith "background-color:yellow;color:red"

-- myLanguage = 
--     emptyDef
--     { opStart         = oneOf "<"
--     , opLetter        = oneOf "<=>"
--     , reservedOpNames = ["<=>"]
-- --    , reservedNames   = ["total", "bottom-reflecting"]
--     , caseSensitive   = True
--     }

-- lexer = P.makeTokenParser emptyDef

-- par   = P.parens     lexer
-- resOp = P.reservedOp lexer


highlt :: (Html -> Html) -> Parser Html
highlt hglt =
    parEOF
    <|>	do{ str  <- ((try (parsBotRefRestriction hglt)) <|> (parAnything hglt));
--	    traceM "highlt: from braced entry";
--	    traceState;
--	    traceM "enter highlt ...";
--	    traceState;
	    str' <- highlt hglt;
--	    traceM "exit highlt ...";
--	    traceState;
	    return (str+++str')
--	     return str
	  }
    <|> try (do{ str  <- keyword;
--		 traceM  "highlt: read keyword";
--		 traceState;
		 str' <- highlt hglt;
--		 traceState;
		 return ((hglt << (toHtml str)) +++ str')
	      })
    <|> do{ str  <- anythingElse;
--	    traceM "highlt: from anythingElse";
--	    traceState;
	    str' <- highlt hglt;
	    return (str+++str')
	  }

tillEndOfBrace hglt =
    do{ char ')';
	return (toHtml "")
      }
    <|>	do{ str  <- ((try (parsBotRefRestriction hglt)) <|> (parAnything hglt));
--	    traceM "tillEndOfBrace: braced entry";
--	    traceState;
	    str' <- tillEndOfBrace hglt;
	    return (str+++str')
--	     return str
	  }
    <|> try (do{ str  <- keyword;
--		 traceM "tillEndOfBrace: read keyword";
--		 traceState;
		 str' <- tillEndOfBrace hglt;
		 return ((hglt << (toHtml str)) +++ str')
	       })
    <|> do{ str  <- anythingElse;
--	    traceM "tillEndOfBrace anythingElse";
--	    traceState;
	    str' <- tillEndOfBrace hglt;
	    return (str+++str')
	  }
    
parEOF :: Parser Html
parEOF = do{ eof;
	    return (toHtml "")
	   }


strEOF :: Parser String
strEOF = do{ eof;
	     return ""
	   }


parAnything :: (Html -> Html) -> Parser Html
parAnything hglt =
    do{ char '(';
        str <- tillEndOfBrace hglt;
--	traceState;
	return ("("+++str+++")")
      }


parsBotRefRestriction :: (Html -> Html) -> Parser Html
parsBotRefRestriction hglt =
    do{ restrict <-  do { char '(';
--			  traceState;
			  char '(';
			  s1 <-  tillEndOfBrace hglt;
--			  traceState;
		          spaces;
			  string "<=>";
                          spaces;
--			  traceState;
			  char '(';
			  s2 <- tillEndOfBrace hglt;
--			  traceState;
			  char ')';
--			  traceM "read highlight restriction.";
--		          traceState;
			  return ("("+++s1+++")"+++" <=> "+++"("+++s2+++")")
			};
	return (hglt << ("("+++restrict+++")"))
      }

brace = (lookAhead (string "(")) <|> (lookAhead (string ")"))
  
anythingElse :: Parser Html
anythingElse =
    do{ str <- manyTill anyChar (brace <|> (try keywordCheck) <|> strEOF);
--	traceM "read anythingElse";
--	traceState;
	return (toHtml str)
      }

keywordCheck = (lookAhead (string "total")) <|> (lookAhead (string "bottom-reflecting"))
keyword = (try (string "total")) <|> (string "bottom-reflecting")