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.Combinator(manyTill, lookAhead, eof)
import Text.Parsec.Prim(ParsecT,Stream,(<|>),try,parse,getParserState)
import Text.ParserCombinators.Parsec.Char(oneOf,char,anyChar,string)
import Text.Parsec
import Language.Haskell.FreeTheorems.Variations.PolySeq.Debug
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"
highlt :: (Html -> Html) -> Parser Html
highlt hglt =
parEOF
<|> do{ str <- ((try (parsBotRefRestriction hglt)) <|> (parAnything hglt));
str' <- highlt hglt;
return (str+++str')
}
<|> try (do{ str <- keyword;
str' <- highlt hglt;
return ((hglt << (toHtml str)) +++ str')
})
<|> do{ str <- anythingElse;
str' <- highlt hglt;
return (str+++str')
}
tillEndOfBrace hglt =
do{ char ')';
return (toHtml "")
}
<|> do{ str <- ((try (parsBotRefRestriction hglt)) <|> (parAnything hglt));
str' <- tillEndOfBrace hglt;
return (str+++str')
}
<|> try (do{ str <- keyword;
str' <- tillEndOfBrace hglt;
return ((hglt << (toHtml str)) +++ str')
})
<|> do{ str <- anythingElse;
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;
return ("("+++str+++")")
}
parsBotRefRestriction :: (Html -> Html) -> Parser Html
parsBotRefRestriction hglt =
do{ restrict <- do { char '(';
char '(';
s1 <- tillEndOfBrace hglt;
spaces;
string "<=>";
spaces;
char '(';
s2 <- tillEndOfBrace hglt;
char ')';
return (if (showHtml s1) == (showHtml s2) then noHtml else("("+++s1+++")"+++" <=> "+++"("+++s2+++")"))
};
ret <- if isNoHtml restrict then removeAnds else (return (toHtml "("+++restrict+++")"));
return (hglt << ret)
}
removeAnds :: Parser Html
removeAnds = do spaces
try (string "&&")
spaces
return noHtml
brace = (lookAhead (string "(")) <|> (lookAhead (string ")"))
anythingElse :: Parser Html
anythingElse =
do{ str <- manyTill anyChar (brace <|> (try keywordCheck) <|> strEOF);
return (toHtml str)
}
keywordCheck = (lookAhead (string "total")) <|> (lookAhead (string "bottom-reflecting"))
keyword = (try (string "total")) <|> (string "bottom-reflecting")