module Main where import Control.Monad.State import Colors import System.IO import Data.Time import System.Directory import System.Environment import Text.Printf import Control.Concurrent type Pool = Chan () doOneFile fname = do t1 <- getCurrentTime doesFileExist (fname ++ ".html") >>= \b -> if b then hPutStrLn stderr $ printf "File already processed, skipping: %s" fname else do out <- openFile (fname ++ ".html") WriteMode hSetBuffering out (BlockBuffering (Just 64000)) srcF <- openFile fname ReadMode hSetBuffering srcF (BlockBuffering (Just 64000)) hPutStrLn out "" hPutStrLn out "" hPutStrLn out "" hPutStrLn out "" -- readFile fname >>= doOneParse out hGetContents srcF >>= doOneParse out hPutStrLn out "" hPutStrLn out "" hPutStrLn out "" t2 <- getCurrentTime hPutStrLn stderr $ printf "File %s processed. It took %s." fname (show $ diffUTCTime t2 t1) hClose out doOneParse :: Handle -> String -> IO () doOneParse hnd str = execStateT (makeHeader >> parse str) emptyStyle >> return () where modifyAndPrint :: (Style -> Style) -> StateT Style IO () modifyAndPrint f = modify f >> get >>= \x -> liftIO (hPutStr hnd (beginSpan x)) makeHeader :: StateT Style IO () makeHeader = modifyAndPrint id parse :: String -> StateT Style IO () parse ('\ESC':'[':'0':'m':rest) = modifyAndPrint (\_ -> emptyStyle) >> parse rest parse ('\ESC':'[':'0':';':'3':'1':'m':rest) = modifyAndPrint (\x -> x { fgcol = red }) >> parse rest parse ('\ESC':'[':'0':';':'3':'2':'m':rest) = modifyAndPrint (\x -> x { fgcol = green }) >> parse rest parse ('\ESC':'[':'0':';':'3':'3':'m':rest) = modifyAndPrint (\x -> x { fgcol = yellow })>> parse rest parse ('\ESC':'[':'0':';':'3':'4':'m':rest) = modifyAndPrint (\x -> x { fgcol = blue })>> parse rest parse ('\ESC':'[':'0':';':'3':'5':'m':rest) = modifyAndPrint (\x -> x { fgcol = magenta })>> parse rest parse ('\ESC':'[':'0':';':'3':'6':'m':rest) = modifyAndPrint (\x -> x { fgcol = cyan })>> parse rest parse ('\ESC':'[':'0':';':'3':'7':'m':rest) = modifyAndPrint (\x -> x { fgcol = white })>> parse rest parse ('\ESC':'[':'0':';':'4':'0':'m':rest) = modifyAndPrint (\x -> x { bgcol = black })>> parse rest parse ('\ESC':'[':'0':';':'4':'1':'m':rest) = modifyAndPrint (\x -> x { bgcol = red })>> parse rest parse ('\ESC':'[':'0':';':'4':'2':'m':rest) = modifyAndPrint (\x -> x { bgcol = green })>> parse rest parse ('\ESC':'[':'0':';':'4':'3':'m':rest) = modifyAndPrint (\x -> x { bgcol = yellow })>> parse rest parse ('\ESC':'[':'0':';':'4':'4':'m':rest) = modifyAndPrint (\x -> x { bgcol = blue })>> parse rest parse ('\ESC':'[':'0':';':'4':'5':'m':rest) = modifyAndPrint (\x -> x { bgcol = magenta })>> parse rest parse ('\ESC':'[':'0':';':'4':'6':'m':rest) = modifyAndPrint (\x -> x { bgcol = cyan })>> parse rest parse ('\ESC':'[':'0':';':'4':'7':'m':rest) = modifyAndPrint (\x -> x { bgcol = white })>> parse rest parse ('\ESC':'[':'1':'m' :rest) = modifyAndPrint (\x -> x { bbold = True })>> parse rest parse ('\ESC':'[':'4':'m' :rest) = modifyAndPrint (\x -> x { uline = True })>> parse rest parse ('\ESC':'[':'5':'m' :rest) = modifyAndPrint (\x -> x { flash = True })>> parse rest parse ('\ESC':'[':'7':'m' :rest) = modifyAndPrint (\x -> x { inverse = True })>> parse rest parse ('\ESC':'[':'1':';':'3':'0':'m':rest) = modifyAndPrint (\x -> x { fgcol = grey })>> parse rest parse ('\ESC':'[':'1':';':'3':'1':'m':rest) = modifyAndPrint (\x -> x { fgcol = light red })>> parse rest parse ('\ESC':'[':'1':';':'3':'2':'m':rest) = modifyAndPrint (\x -> x { fgcol = light green })>> parse rest parse ('\ESC':'[':'1':';':'3':'3':'m':rest) = modifyAndPrint (\x -> x { fgcol = light yellow })>> parse rest parse ('\ESC':'[':'1':';':'3':'4':'m':rest) = modifyAndPrint (\x -> x { fgcol = light blue })>> parse rest parse ('\ESC':'[':'1':';':'3':'5':'m':rest) = modifyAndPrint (\x -> x { fgcol = light magenta })>> parse rest parse ('\ESC':'[':'1':';':'3':'6':'m':rest) = modifyAndPrint (\x -> x { fgcol = light cyan })>> parse rest parse ('\ESC':'[':'1':';':'3':'7':'m':rest) = modifyAndPrint (\x -> x { fgcol = light white })>> parse rest parse ('\ESC':'[':'1':';':'4':'0':'m':rest) = modifyAndPrint (\x -> x { bgcol = light black })>> parse rest parse ('\ESC':'[':'1':';':'4':'1':'m':rest) = modifyAndPrint (\x -> x { bgcol = light red })>> parse rest parse ('\ESC':'[':'1':';':'4':'2':'m':rest) = modifyAndPrint (\x -> x { bgcol = light green })>> parse rest parse ('\ESC':'[':'1':';':'4':'3':'m':rest) = modifyAndPrint (\x -> x { bgcol = light yellow })>> parse rest parse ('\ESC':'[':'1':';':'4':'4':'m':rest) = modifyAndPrint (\x -> x { bgcol = light blue })>> parse rest parse ('\ESC':'[':'1':';':'4':'5':'m':rest) = modifyAndPrint (\x -> x { bgcol = light magenta })>> parse rest parse ('\ESC':'[':'1':';':'4':'6':'m':rest) = modifyAndPrint (\x -> x { bgcol = light cyan })>> parse rest parse ('\ESC':'[':'1':';':'4':'7':'m':rest) = modifyAndPrint (\x -> x { bgcol = light white })>> parse rest parse (c:rest) = liftIO (hPutChar hnd c) >> parse rest parse [] = return () --- {- 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 () sparkComp :: Pool -> IO () -> IO (MVar ()) sparkComp pool comp = do takeFromPool pool mvar <- newEmptyMVar forkOS $ (comp >> fillPool pool >> putMVar mvar ()) -- core dumped once, when changed do forkOS and run with -N2 return mvar mapMPar :: (a -> IO ()) -> [a] -> IO () mapMPar comp lst = do tPool <- makeThreadPool numThreads mvars <- mapM (sparkComp tPool) (map comp lst) mapM_ takeMVar (mvars :: [MVar ()]) return () numThreads = 2 {- -} main :: IO () main = getArgs >>= mapMPar doOneFile