ehaskell 0.4 → 0.5
raw patch · 2 files changed
+162/−58 lines, 2 files
Files
- Main.hs +160/−57
- ehaskell.cabal +2/−1
Main.hs view
@@ -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"
ehaskell.cabal view
@@ -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