{-# OPTIONS_GHC -XFlexibleContexts #-}
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
(MonadPlus, MonadParse, Parse, runParse, ParseT, evalParseT,
spot, spotBack, token, tokenBack, tokens, parseNot, still,
optional, list, greedyList, neList, greedyNeList,
mplus, endOfInput, lift)
import YJTools.Tribial (ghcMake)
import Data.Char (isSpace, isUpper, isLower, isDigit)
import Data.Function.Tools (applyUnless)
import Prelude hiding (readFile, writeFile)
import System.IO (stderr)
import System.IO.UTF8 (readFile, writeFile, hPutStr)
ehaskellDir, haskellSffx, ehsHandleStr, putStrStr :: String
ehaskellDir = "_ehs/"
haskellSffx = ".hs"
ehsHandleStr = "_ehs_handle"
putStrStr = "hPutStr " ++ ehsHandleStr
data CodePos = Import | Top | Definition | Inner deriving (Eq, Enum, Show)
main :: IO ()
main = do
args <- getArgs
let eqs = takeOptionEq args
args_ = dropOptionEq args
[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
case runParse (parseAll eqs) ("", cont) of
[] -> hPutStr stderr "parse error" >> return ()
(((p,ips),_):_) -> writeFile srcFile p >> mapM_ (evalParseT (copyImports edir) . ((,) "")) ips
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 -> do runProcess exeFile [fn] Nothing Nothing Nothing Nothing Nothing >>= waitForProcess
return ()
copyImports :: String -> ParseT Char IO ()
copyImports dir = do
tokens "import"
neList $ spot $ isSpace
mn <- neList (spot $ \c -> not (isSpace c) && notElem c "()") >>= skipRet (still $ spot $ \c -> isSpace c || elem c "(%")
list $ spot isSpace
optional parseParenthesis
list $ spot isSpace
endOfInput ()
let sfn = mn ++ ".hs"
dfn = dir ++ sfn
lift $ whenM (doesFileExist sfn) $ whenM (doesNotExistOrOldThan dfn sfn) $
copyFile sfn dfn
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
takeOptionEq :: [String] -> [String]
takeOptionEq [] = []
takeOptionEq (('-':_):as) = takeOptionEq as
takeOptionEq (a:as)
| elem '=' a = a : takeOptionEq as
| otherwise = takeOptionEq as
dropOptionEq :: [String] -> [String]
dropOptionEq [] = []
dropOptionEq (a@('-':_):as) = a : dropOptionEq as
dropOptionEq (a:as)
| elem '=' a = dropOptionEq as
| otherwise = a : dropOptionEq as
parseAll :: [String] -> Parse Char (String, [String])
parseInnerPlain, parseString :: (Functor m, MonadPlus m, MonadParse Char m) => m String
parseParenthesis, parseInner :: (Functor m, MonadPlus m, MonadParse Char m) => m String
parseImport, parseDef, parseTop :: Parse Char (CodePos, String)
parse, parseApply :: Parse Char [ (CodePos, String) ]
parseText, parseN, parseEq, parseEqEq, parseEqShow, parseEqEqShow
:: Parse Char (CodePos, String)
parseApplyBegin, parseApplyContinue, parseApplyEnd, parseVarid
:: Parse Char String
mkOutputText, mkOutputTop, mkOutputHere,
mkOutputCode, mkOutputShowCode, mkOutputReturnCode, mkOutputReturnShowCode
:: String -> String
mkOutputImport :: String -> [String] -> String
mkOutputDef :: String -> String -> String
getHandleStr :: String
parseAll eqs
= ( getSrcAndImports
. (map (\eq -> (Definition, mkOutputTop eq)) eqs ++)
. filter (notOverwrided eqs)
. ((Inner, "main = do {\n"++getHandleStr):)
. (++[(Inner, " hClose " ++ ehsHandleStr ++ " }\n")])
. ((Import, "import System.IO (stdout, openFile, IOMode(WriteMode), hClose)\n"):)
. ((Import, "import System.IO.UTF8 (hPutStr)\n"):)
. ((Import, "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 parseImport
`mplus`
single parseDef
`mplus`
single parseTop
`mplus`
parseApply )
where single = ((:[]) <$>)
myConcat :: [ (Bool, [a]) ] -> [a]
myConcat lst
= concat (map snd $ filter fst lst) ++
concat (map snd $ filter (not . fst) lst)
getSrcAndImports :: [ (CodePos, String) ] -> (String, [String])
getSrcAndImports lst = (myConcat2 lst, map snd $ filter ((==Import).fst) $ lst)
notOverwrided :: [ String ] -> (CodePos, String) -> Bool
notOverwrided eqs (Definition, def)
= (fst $ head $ runParse parseVarid $ ("", def)) `notElem`
map (fst . head . runParse parseVarid . (,) "") eqs
notOverwrided _ _ = True
myConcat2 :: (Eq e, Enum e) => [ (e, [a]) ] -> [a]
myConcat2 lst = mcc (toEnum 0) lst
where
mcc _ [] = []
mcc e lt = concat (map snd $ filter ((==e) . fst) lt) ++
mcc (succ e) ( filter ((/=e) . fst) lt)
parseText = do
cont <- greedyNeList $ do
still $ parseNot () $ tokens "<%"
spot $ const True
return $ (Inner, mkOutputText cont)
parseN = do
tokens "<%" >> still (parseNot () $ spot $ flip elem "-=%")
code <- parseInner
still (parseNot () $ tokenBack '-')
tokens "%>"
return $ (Inner, mkOutputHere code)
parseEq = do
tokens "<%=" >> still (parseNot () $ spot $ flip elem "=$")
code <- parseInner
tokens "%>"
return $ (Inner, mkOutputReturnCode code)
parseEqEq = do
tokens "<%==" >> still (parseNot () $ token '$')
code <- parseInner
tokens "%>"
return $ (Inner, mkOutputCode code)
parseEqShow = do
tokens "<%=$"
code <- parseInner
tokens "%>"
return $ (Inner, mkOutputReturnShowCode code)
parseEqEqShow = do
tokens "<%==$"
code <- parseInner
tokens "%>"
return $ (Inner, mkOutputShowCode code)
parseImport = do
tokens "<%%"
list $ spot isSpace
tokens "import"
list $ spot isSpace
mn <- neList (spot $ not . isSpace) >>= skipRet (still $ spot $ isSpace)
list $ spot isSpace
ips <- optional parseParenthesis
list $ spot isSpace
tokens "%%>"
return $ (Import, mkOutputImport mn ips)
parseDef = do
tokens "<%%"
var <- parseInner
list $ spot isSpace
token '='
list $ spot isSpace
val <- parseInner
tokens "%%>"
return $ (Definition, mkOutputDef var val)
parseTop = do
tokens "<%%"
code <- parseInner
tokens "%%>"
return $ (Top, mkOutputTop code)
parseApply = do
b <- parseApplyBegin
c <- surround <$> parse
cs <- list $ do
ci <- parseApplyContinue
t <- surround <$> parse
return $ (Inner, ci) : t
e <- parseApplyEnd
return $ (Inner, b) : c ++ concat cs ++ [(Inner, e)] ++ [(Inner, ";\n")]
where
surround = ( ++ [ (Inner, " })") ] ).( (Inner, "(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)
still $ spot $ not . isSpace
fmap concat $ list $ (parseInnerPlain >>= skipRet (still $ parseNot () $ parseInnerPlain))
`mplus`
parseString
`mplus`
parseParenthesis
parseInnerPlain = neList $ do
still (parseNot () $ tokens "%>")
still (parseNot () $ tokens "-%>")
still (parseNot () $ tokens "%%>")
still (parseNot () $ (still (spotBack (not . isAscSymbol)) >> token '=') `mplus`
(token '=' >> spot (not . isAscSymbol)))
spot (flip notElem "\"(")
where
isAscSymbol :: Char -> Bool
isAscSymbol = flip elem "!#$%&*+./<=>?@\\^|-~"
parseString = do
token '"'
ret <- fmap concat $ list
$ ((:[]) <$> spot (flip notElem "\"\\")) `mplus`
do { token '\\'; c <- spot (const True); return ['\\', c] }
token '"'
return $ '"' : ret ++ "\""
parseParenthesis = do
token '('
ret <- fmap concat $ list
$ ((:[]) <$> spot (flip notElem "()")) `mplus`
parseParenthesis
token ')'
return $ '(' : ret ++ ")"
parseVarid = do
still $ parseNot () $ spotBack isTail
h <- spot isHead
t <- list $ spot isTail
still $ parseNot () $ spot isTail
return $ h : t
where
isHead c = isLower c || c == '_'
isTail c = isHead c || isUpper c || isDigit c || c == '\''
mkOutputText txt = " " ++ putStrStr ++ " $ " ++ show txt ++ ";\n"
mkOutputImport md [] = "import " ++ md ++ "\n"
mkOutputImport md [ips] = "import " ++ md ++ ips ++ "\n"
mkOutputDef var val = var ++ " = " ++ val ++ ";\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"