ehaskell-0.2: Main.hs

module Main where

import System.Environment     (getArgs)
import System.Directory       (doesDirectoryExist, createDirectory, copyFile, doesFileExist)
import System.Directory.Tools (doesNotExistOrOldThan)
import System.Process         (runProcess, waitForProcess)
import Control.Monad.Tools    (whenM, unlessM, skipRet)
import Control.Applicative    ((<$>))
import Text.RegexPR           (gsubRegexPR)
import Text.ParserCombinators.MTLParse
import YJTools.Tribial        (ghcMake)
import Data.Char              (isSpace)
import Data.Maybe             (maybeToList)

ehaskellDir, haskellSffx, ehsHandleStr, putStrStr :: String
ehaskellDir  = "_ehs/"
haskellSffx  = ".hs"
ehsHandleStr = "_ehs_handle"
putStrStr    = "hPutStr " ++ ehsHandleStr

main :: IO ()
main = do
  args <- getArgs
  let [infile] = dropOptionO args
      outfile  = takeOptionO args
      exeName = gsubRegexPR "\\." "_" infile
      exeFile = ehaskellDir ++ exeName
      srcFile = ehaskellDir ++ exeName ++ haskellSffx
  cont       <- readFile infile
  unlessM (doesDirectoryExist ehaskellDir) $ createDirectory ehaskellDir
  copyRequiredFile cont
  whenM   (doesNotExistOrOldThan srcFile infile)  $
    writeFile srcFile $ fst $ head $ runParse parseAll ("", cont)
  whenM (doesNotExistOrOldThan exeFile srcFile) $
    ghcMake exeName ehaskellDir >> return ()
  runProcess exeFile (maybeToList outfile) Nothing Nothing Nothing Nothing Nothing
    >>= waitForProcess
  return ()

copyRequiredFile :: String -> IO ()
copyRequiredFile src = evalParseT copyRequiredFileParse ("",src) >> return ()

copyRequiredFileParse :: ParseT Char IO ()
copyRequiredFileParse = list crfp >> return ()
  where
  crfp = do
    list $ do
      still $ parseNot () $ tokens "<%%"
      spot $ const True
    tokens "<%%"
    list $ spot isSpace
    tokens "import"
    list $ spot isSpace
    mn <- neList (spot $ not . isSpace) >>= skipRet (still $ spot $ isSpace)
    let sfn = mn ++ ".hs"
        dfn = ehaskellDir ++ sfn
    lift $ whenM (doesFileExist sfn) $ whenM (doesNotExistOrOldThan dfn sfn) $
      copyFile sfn dfn
    list $ spot isSpace
    tokens "%%>"

takeOptionO :: [String] -> Maybe String
takeOptionO []         = Nothing
takeOptionO ("-o":f:_) = Just f
takeOptionO (_:as)     = takeOptionO as
dropOptionO :: [String] -> [String]
dropOptionO []          = []
dropOptionO ("-o":_:as) = as
dropOptionO (a:as)      = a : dropOptionO as

parseAll, parseInner                     :: Parse Char String
parse, parseApply                        :: Parse Char [ (Bool, String) ]
parseText, parseN, parseEq, parseEqEq, parseEqShow, parseEqEqShow, parseDef
                                         :: Parse Char (Bool, String)
parseApplyBegin, parseApplyContinue, parseApplyEnd
                                         :: Parse Char String
mkOutputText, mkOutputHere,
  mkOutputCode, mkOutputShowCode, mkOutputReturnCode, mkOutputReturnShowCode
                                         :: String -> String
getHandleStr                             :: String

parseAll
  = ( myConcat . ((False, "main = do {\n"++getHandleStr):)
               . (++[(False, "  hClose " ++ ehsHandleStr ++ " }\n")])
	       . ((True, "import System.IO (stdout, hPutStr, openFile, IOMode(WriteMode), hClose)\n"):)
	       . ((True, "import System.Environment (getArgs)\n"):) )
        <$> parse >>= endOfInput

getHandleStr = "  " ++ ehsHandleStr ++
               " <- getArgs >>= (\\args -> " ++
	       "if null args then return stdout else openFile (head args) WriteMode);\n"

parse = concat <$>
  ( greedyNeList $ (single parseText >>= \r -> still (parseNot r $ parseText))
             `mplus`
	     single parseN
             `mplus`
	     single parseEq
	     `mplus`
	     single parseEqEq
	     `mplus`
	     single parseEqShow
	     `mplus`
	     single parseEqEqShow
	     `mplus`
             single parseDef
             `mplus`
             parseApply )
  where single = ((:[]) <$>)

myConcat :: [ (Bool, [a]) ] -> [a]
myConcat lst
  = concat (map snd $ filter fst lst) ++
    concat (map snd $ filter (not . fst) lst)

parseText = do
  cont <- greedyNeList $ do
    still $ parseNot () $ tokens "<%"
    spot $ const True
  return $ (False, mkOutputText cont)

parseN = do
  tokens "<%" >> still (parseNot () $ spot $ flip elem "-=%")
  code <- parseInner
  still (parseNot () $ tokenBack '-')
  tokens "%>"
  return $ (False, mkOutputHere code)

parseEq = do
  tokens "<%=" >> still (parseNot () $ spot $ flip elem "=$")
  code <- parseInner
  tokens "%>"
  return $ (False, mkOutputReturnCode code)

parseEqEq = do
  tokens "<%==" >> still (parseNot () $ token '$')
  code <- parseInner
  tokens "%>"
  return $ (False, mkOutputCode code)

parseEqShow  = do
  tokens "<%=$"
  code <- parseInner
  tokens "%>"
  return $ (False, mkOutputReturnShowCode code)

parseEqEqShow  = do
  tokens "<%==$"
  code <- parseInner
  tokens "%>"
  return $ (False, mkOutputShowCode code)

parseDef = do
  tokens "<%%"
  code <- parseInner
  tokens "%%>"
  return $ (True, code ++ ";\n")

parseApply = do
  b  <- parseApplyBegin
  c  <- surround <$> parse
  cs <- list $ do
          ci <- parseApplyContinue
          t  <- surround <$> parse
          return $ (False, ci) : t
  e <- parseApplyEnd
  return $ (False, b) : c ++ concat cs ++ [(False, e)] ++ [(False, ";\n")]
  where
  surround = ( ++ [ (False, " })") ] ).( (False, "(do{\n") : )

parseApplyBegin = do
  tokens "<%"
  code <- parseInner
  tokens "-%>"
  return code

parseApplyContinue = do
  tokens "<%-"
  code <- parseInner
  tokens "-%>"
  return code

parseApplyEnd = do
  tokens "<%-"
  code <- parseInner
  tokens "%>"
  return code

parseInner = do
  greedyList (spot isSpace)
  greedyList $ do
    still (parseNot () $ tokens "%>")
    spot (const True)

mkOutputText txt            = "  " ++ putStrStr ++ " $ " ++ show txt ++ ";\n"
mkOutputHere code           = "  " ++ code ++ ";\n"
mkOutputCode code           = "  " ++ code ++ " >>= " ++ putStrStr ++ ";\n"
mkOutputShowCode code       = "  " ++ code ++ " >>= " ++ putStrStr ++ ". show ;\n"
mkOutputReturnCode code     = "  " ++ putStrStr ++ " $ " ++ code ++ " ;\n"
mkOutputReturnShowCode code = "  " ++ putStrStr ++ " $ show" ++ code ++ " ;\n"