ehaskell-0.3: 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 System.FilePath        (takeDirectory, takeFileName)
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)
import Data.Function.Tools    (applyUnless)

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
      edir     = let d = takeDirectory infile
                  in applyUnless (null d) ((d ++ "/") ++) ehaskellDir
      exeName  = gsubRegexPR "\\." "_" $ takeFileName infile
      exeFile  = edir ++ exeName
      srcFile  = edir ++ exeName ++ haskellSffx
  cont       <- readFile infile
  unlessM (doesDirectoryExist edir) $ createDirectory edir
  copyRequiredFile edir cont
  whenM   (doesNotExistOrOldThan srcFile infile)  $
    writeFile srcFile $ fst $ head $ runParse parseAll ("", cont)
  whenM (doesNotExistOrOldThan exeFile srcFile) $
    ghcMake exeName edir >> return ()
  runProcess exeFile (maybeToList outfile) Nothing Nothing Nothing Nothing Nothing
    >>= waitForProcess
  return ()

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

copyRequiredFileParse :: FilePath -> ParseT Char IO ()
copyRequiredFileParse dir = 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 = dir ++ 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"