{-# OPTIONS_GHC -XPatternSignatures -XBangPatterns #-}

module Main where

import System.IO
import System.Process
import System.Directory
import System.Environment
import Text.ParserCombinators.Parsec
import Text.Printf
import Data.Maybe
import Control.Monad
import Control.Monad.State
import Control.Concurrent
import Control.Exception( evaluate )
import Debug.Trace
import Data.Time

import Control.Parallel.Strategies

type Pool = Chan ()

data CharOrColor = Ch !Char 
                 | St !(Style -> Style)

instance Show CharOrColor where
    show (Ch x) = [x]
    show (St t) = show (t emptyStyle)

type CCode = (Int,Int,Int)

data Style = Style { fgcol :: !CCode, 
                     bgcol :: !CCode, 
                     bbold :: !Bool, 
                     uline :: !Bool, 
                     flash :: !Bool, 
                     inverse :: !Bool }
           deriving (Show)

beginSpan :: Style -> String
beginSpan !style = let format = "<span style=\"color: #%02x%02x%02x; background-color: #%02x%02x%02x; font-weight: %s%s%s\">" in
                   let (!r1,!g1,!b1) :: CCode = if inverse style then bgcol style else fgcol style in
                   let (!r2,!g2,!b2) :: CCode = if inverse style then fgcol style else bgcol style in
                   let bold :: String = if bbold style then "bold" else "normal" in
                   let underline :: String = if uline style then "; text-decoration: underline" else "" in
                   let flashy :: String = if flash style then "; text-decoration: blink" else "" in
                   printf format r1 g1 b1 r2 g2 b2 bold underline flashy

{- Printf version is clearer, but slower 
beginSpan :: Style -> String
beginSpan !style = let format = "<span style=\"color: #%02x%02x%02x; background-color: #%02x%02x%02x; font-weight: %s%s%s\">" in
                   let col1 :: CCode = if inverse style then bgcol style else fgcol style in
                   let col2 :: CCode = if inverse style then fgcol style else bgcol style in
                   let bold :: String = if bbold style then "bold" else "normal" in
                   let underline :: String = if uline style then "; text-decoration: underline" else "" in
                   let flashy :: String = if flash style then "; text-decoration: blink" else "" in
                   "<span style=\"color: " ++ formatCol col1 ++ "; background-color: " ++ formatCol col2 ++ "; font-weight: " ++ bold ++ underline ++ flashy ++ "\">"
 -}
                  
formatCol :: CCode -> String
formatCol (!r,!g,!b) = printf "#%02x%02x%02x" r g b

emptyStyle = Style { fgcol = white, 
                     bgcol = black, 
                     bbold = False, 
                     uline = False, 
                     inverse = False,
                     flash = False
                   }

red = (251,35,23) :: CCode
green = (24,251,24) :: CCode
yellow = (220,200,24) :: CCode
blue = (34,24,251) :: CCode
magenta = (197,0,255) :: CCode
cyan = (83,255,255) :: CCode
white = (255,255,255) :: CCode
grey = (100,100,100) :: CCode
black = (0,0,0) :: CCode

light :: CCode -> CCode
light (!r,!g,!b) = (min (r+100) 255, min (g+100) 255, min (b+100) 255 )



colorParser = do 
  char '\ESC'
  char '['
  code0 <|> code1 <|> code4 <|> code5 <|> code7

code0 = do
  char '0'
  clear <|> code0'

code1 = do
  char '1' 
  bold <|> code1'

code0' = do
  char ';'
  mod <- parseMod
  col <- justColor
  char 'm'
  return $ St (mod col)

code1' = do
  char ';'
  mod <- parseMod
  col <- justColor
  char 'm'
  return $ St (mod (light col))

parseMod = fgcolP <|> bgcolP
    where
      fgcolP = char '3' >> return (\y x -> x { fgcol = y } )
      bgcolP = char '4' >> return (\y x -> x { bgcol = y } )

justColor = pGrey <|> pRed <|> pGreen <|> pYellow <|> pBlue <|> pMagenta <|> pCyan <|> pWhite
    where
      pGrey    = char '0' >> return grey
      pRed     = char '1' >> return red
      pGreen   = char '2' >> return green
      pYellow  = char '3' >> return yellow
      pBlue    = char '4' >> return blue
      pMagenta = char '5' >> return magenta
      pCyan    = char '6' >> return cyan
      pWhite   = char '7' >> return white

--

clear = do
  char 'm'
  return $ St (\_ -> emptyStyle)

bold = do
  char 'm'
  return $ St (\ x -> x{ bbold = True } )

code4 = do
  string "4m"
  return $ St (\ x -> x{ uline = True } )

code5 = do
  string "7m"
  return $ St (\ x -> x{ flash = True } )

code7 = do
  string "5m"
  return $ St (\ x -> x{ inverse = True } )

dataParser :: Parser CharOrColor
dataParser = try colorParser <|> (anyChar >>= (\x -> return (Ch x)))

mainParser :: Parser [CharOrColor]
mainParser = many dataParser

{- Replaced by state monad version
hPrintHtml :: Handle -> Style -> CharOrColor -> IO Style

hPrintHtml hnd state (Ch '\n') = do
  hPutStrLn hnd "<br>"
  return state

hPrintHtml hnd state (Ch ' ') = do
  hPutStr hnd "&nbsp;"
  return state

hPrintHtml hnd state (Ch '<') = do
  hPutStr hnd "&lt;"
  return state

hPrintHtml hnd state (Ch '>') = do
  hPutStr hnd "&gt;"
  return state

hPrintHtml hnd state (Ch x) = do 
  hPutStr hnd [x]
  return state

hPrintHtml hnd state (St st) = do
  hPutStr hnd "</span>"
  hPutStr hnd (beginSpan (st state))
  return (st state)
-}

hPrintHtml :: CharOrColor -> StateT (Handle,Style) IO ()
hPrintHtml (Ch '\n') = do
  (hnd,_) <- get
  liftIO $ hPutStrLn hnd "<br>"

hPrintHtml (Ch ' ') = do
  (hnd,_) <- get
  liftIO $ hPutStr hnd "&nbsp;"

hPrintHtml (Ch '<') = do
  (hnd,_) <- get
  liftIO $ hPutStr hnd "&lt;"

hPrintHtml (Ch '>') = do
  (hnd,_) <- get
  liftIO $ hPutStr hnd "&gt;"

hPrintHtml (Ch x) = do 
  (hnd,_) <- get
  liftIO $ hPutChar hnd x

hPrintHtml (St st) = do
  (hnd,style) <- get
  put (hnd,st style)
  (_,style2) <- get
  liftIO $ hPutStr hnd $ "</span>" ++ (beginSpan $ style2)


split :: (Eq a) => a -> [a] -> [[a]]
split c str = let (p,ps) = aux str in (p:ps)
    where
      aux     [] = ([],[])
      aux (x:cs) = let (xs,xss) = aux cs in 
                   if x == c then ([c],(xs:xss)) else ((x:xs),xss)

splitPred :: (Eq a) => (a -> Bool) -> [a] -> [[a]]
splitPred pr str = let (p,ps) = aux str in (p:ps)
    where
      aux     [] = ([],[])
      aux (x:cs) = let (xs,xss) = aux cs in 
                   if pr x then ([],((x:xs):xss)) else ((x:xs),xss)

{-
split :: (Eq a) => a -> [a] -> [[a]]
split c str = aux [] str where
    aux acc [] = [acc]
    aux acc (x:xs) = if x == c then (acc++[x]) : (aux [] xs) else aux (acc++[x]) xs
-}
{-
splitPred :: (Eq a) => (a -> Bool) -> [a] -> [[a]]
splitPred pred str = aux [] str where
    aux acc [] = [acc]
    aux acc (x:xs) = if pred x then acc : (aux [x] xs) else aux (acc++[x]) xs
-}

doOneFile :: String -> IO ()
doOneFile fname = do
  t1 <- getCurrentTime
  doesFileExist (fname ++ ".html") >>= \b -> if b then hPutStrLn stderr $ printf "File already processed, skipping: %s" fname else do
    src <- readFile fname
    out <- openFile (fname ++ ".html") WriteMode
    hSetBuffering out (BlockBuffering (Just 64000))
    hPutStrLn out "<html>"
    hPutStrLn out "<body bgcolor=\"black\">"
    hPutStrLn out "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\">"
    hPutStrLn out "<span style=\"font-family: monospace; font-size: 13;\" ><span>"
    let extractData = \p -> case p of
                              Right x -> x
                              Left err -> (trace . show $ err) []
    let srcSplit = splitPred (`elem`"\n") src
    let parsed = concatMap (extractData . parse mainParser fname) srcSplit
    execStateT (hPrintHtml (St id)) (out,emptyStyle) -- wypisujemy pierwszy wiersz
    execStateT (mapM_ hPrintHtml parsed) (out,emptyStyle)
    hPutStrLn out "</span></span>"
    hPutStrLn out "</body>"
    hPutStrLn out "</html>"
    t2 <- getCurrentTime
    hPutStrLn stderr $ printf "File %s processed. It took %s. File size was %d characters." fname (show $ diffUTCTime t2 t1) (length src)
    hClose out

{- thread pool stuff -}

takeFromPool :: Pool -> IO ()
takeFromPool p = readChan p >> return ()

fillPool :: Pool -> IO ()
fillPool p = writeChan p ()

makeThreadPool :: Int -> IO Pool
makeThreadPool num = do
  p <- newChan
  repeatNum num (fillPool p)
  return p

repeatNum :: Int -> IO () -> IO ()
repeatNum n act | n > 0     = act >> (repeatNum (n-1) act)
                | otherwise = return ()

{- end thread pool stuff -}

sparkComp :: Pool -> IO () -> IO (MVar ())
sparkComp pool comp = do
  takeFromPool pool
  mvar <- newEmptyMVar
  forkIO $ (comp >> fillPool pool >> putMVar mvar ()) -- core dumped once, when changed do forkOS and run with -N2
  return mvar

mapMPar :: (a -> IO ()) -> [a] -> Int -> IO ()
mapMPar comp lst numT = do
  tPool <- makeThreadPool numT
  mvars <- mapM (sparkComp tPool) (map comp lst)
  mapM_ takeMVar (mvars :: [MVar ()])
  return ()

numThreads = 1

{- -}

mapMPar' :: (a -> IO ()) -> [a] -> IO ()
mapMPar' comp lst = mapM_ (\a -> sparkComp' (comp a)) lst

sparkComp' :: IO a -> IO ()
sparkComp' comp = do
  mvar <- newEmptyMVar
  forkIO $ (comp >> putMVar mvar ())
  takeMVar mvar

{- -}

main :: IO ()
main = do
  args <- getArgs
  pn <- getProgName
--  if args == [] then runCommand (pn ++ " *.log") >>= waitForProcess >> return () else mapM_ doOneFile args
  mapM_ doOneFile args
--  mapMPar doOneFile args numThreads
--  mapMPar' doOneFile args
  return ()