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 System.Exit (ExitCode(ExitSuccess), exitWith)
import Control.Monad (when)
import Control.Monad.Tools (whenM, unlessM, skipRet)
import Control.Applicative ((<$>))
import Text.RegexPR (gsubRegexPR)
import Text.ParserCombinators.MTLParse
(Parse, runParse, ParseT, evalParseT,
spot, token, tokenBack, tokens, parseNot,
still, greedyList, list, neList, greedyNeList,
mplus, endOfInput, lift)
import YJTools.Tribial (ghcMake)
import Data.Char (isSpace)
import Data.Function.Tools (applyUnless)
import Prelude hiding (readFile, writeFile)
import System.IO.UTF8 (readFile, writeFile)
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) $ do
ec <- ghcMake exeName edir
when (ec /= ExitSuccess) $ exitWith ec
case outfile of
Nothing -> do runProcess exeFile [] Nothing Nothing Nothing Nothing Nothing >>= waitForProcess
return ()
Just fn -> whenM (doesNotExistOrOldThan fn exeFile) $ do
runProcess exeFile [fn] 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, mkOutputTop, 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, openFile, IOMode(WriteMode), hClose)\n"):)
. ((True, "import System.IO.UTF8 (hPutStr)\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, mkOutputTop code)
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"
mkOutputTop code = code ++ ";\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"