module Code(code, codeFKw, codeCFKw, hsKws) where
import Char
import SlideWare

code :: String -> Pict
code s = codeFKw hsKws True s

codeFKw :: [String] -> Bool -> String -> Pict
codeFKw kws fill s = codeCFKw (colorize codeColor . tt) kws fill s

codeCFKw :: (String -> Pict) -> [String] -> Bool -> String -> Pict
codeCFKw fun kws fill s =
    let ps = map (hbAppend' . codeLine fun kws "") (lines s)
	wide = blank clientW 0
	multi = '\n' `elem` s
    in  if fill && multi then
	    hbAppend [tt " ", vlAppend (wide : ps)]
	else
	    vlAppend' ps

hbAppend' [p] = p
hbAppend' ps = hbAppend ps
vlAppend' [p] = p
vlAppend' ps = vlAppend ps

codeLine fun kws a "" = plain a
codeLine fun kws a s =
    let (w, s') = span isAlphaNum s
	(nw, s'') = span (not . isAlpha) s'
	isComm ('-':'-':_) = True
	isComm (c:cs) = isComm cs
	isComm "" = False
	rest r = if isComm nw then codeLine fun kws (r++nw++s'') "" else codeLine fun kws (r++nw) s''
    in  if w `elem` kws then
	     plain a ++ keyword fun w ++ rest ""
	else
	     rest (a ++ w)

plain "" = []
plain s = [tt s]

keyword fun w = [fun w]

hsKws = [
	"type", "data", "let", "in", "case", "of", "module", "class", "where",
	"instance", "import", "do", "deriving", "if", "then", "else", "newtype",
	"hiding", "infix", "infixl", "infixr", "foreign"
	]

codeColor = "blue"