diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -XFlexibleContexts #-} module Main where import System.Environment (getArgs) @@ -11,15 +12,16 @@ 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, + (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) +import Data.Char (isSpace, isUpper, isLower, isDigit) import Data.Function.Tools (applyUnless) import Prelude hiding (readFile, writeFile) -import System.IO.UTF8 (readFile, writeFile) +import System.IO (stderr) +import System.IO.UTF8 (readFile, writeFile, hPutStr) ehaskellDir, haskellSffx, ehsHandleStr, putStrStr :: String ehaskellDir = "_ehs/" @@ -27,11 +29,15 @@ ehsHandleStr = "_ehs_handle" putStrStr = "hPutStr " ++ ehsHandleStr +data CodePos = Import | Top | Definition | Inner deriving (Eq, Enum, Show) + main :: IO () main = do args <- getArgs - let [infile] = dropOptionO args - outfile = takeOptionO args + 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 @@ -39,40 +45,31 @@ 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) + 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 -> whenM (doesNotExistOrOldThan fn exeFile) $ do - runProcess exeFile [fn] Nothing Nothing Nothing Nothing Nothing >>= waitForProcess + Just fn -> 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 "%%>" +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 @@ -83,23 +80,44 @@ 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 +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 - = ( 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"):) ) +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 ++ @@ -119,7 +137,11 @@ `mplus` single parseEqEqShow `mplus` + single parseImport + `mplus` single parseDef + `mplus` + single parseTop `mplus` parseApply ) where single = ((:[]) <$>) @@ -129,48 +151,86 @@ = 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 $ (False, mkOutputText cont) + return $ (Inner, mkOutputText cont) parseN = do tokens "<%" >> still (parseNot () $ spot $ flip elem "-=%") code <- parseInner still (parseNot () $ tokenBack '-') tokens "%>" - return $ (False, mkOutputHere code) + return $ (Inner, mkOutputHere code) parseEq = do tokens "<%=" >> still (parseNot () $ spot $ flip elem "=$") code <- parseInner tokens "%>" - return $ (False, mkOutputReturnCode code) + return $ (Inner, mkOutputReturnCode code) parseEqEq = do tokens "<%==" >> still (parseNot () $ token '$') code <- parseInner tokens "%>" - return $ (False, mkOutputCode code) + return $ (Inner, mkOutputCode code) parseEqShow = do tokens "<%=$" code <- parseInner tokens "%>" - return $ (False, mkOutputReturnShowCode code) + return $ (Inner, mkOutputReturnShowCode code) parseEqEqShow = do tokens "<%==$" code <- parseInner tokens "%>" - return $ (False, mkOutputShowCode code) + 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 $ (True, mkOutputTop code) + return $ (Top, mkOutputTop code) parseApply = do b <- parseApplyBegin @@ -178,11 +238,11 @@ cs <- list $ do ci <- parseApplyContinue t <- surround <$> parse - return $ (False, ci) : t + return $ (Inner, ci) : t e <- parseApplyEnd - return $ (False, b) : c ++ concat cs ++ [(False, e)] ++ [(False, ";\n")] + return $ (Inner, b) : c ++ concat cs ++ [(Inner, e)] ++ [(Inner, ";\n")] where - surround = ( ++ [ (False, " })") ] ).( (False, "(do{\n") : ) + surround = ( ++ [ (Inner, " })") ] ).( (Inner, "(do{\n") : ) parseApplyBegin = do tokens "<%" @@ -204,11 +264,54 @@ parseInner = do greedyList (spot isSpace) - greedyList $ do - still (parseNot () $ tokens "%>") - spot (const True) + 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" diff --git a/ehaskell.cabal b/ehaskell.cabal --- a/ehaskell.cabal +++ b/ehaskell.cabal @@ -1,5 +1,5 @@ Name: ehaskell -Version: 0.4 +Version: 0.5 Cabal-Version: >= 1.2 Build-Type: Simple License: GPL @@ -46,3 +46,4 @@ Main-Is: Main.hs Build-Depends: base, mtlparse >= 0.0.1, yjtools >= 0.8, directory, regexpr >= 0.3.3, process, filepath, utf8-string GHC-Options: -Wall + Extensions: FlexibleContexts