diff --git a/EHaskell.hs b/EHaskell.hs new file mode 100644 --- /dev/null +++ b/EHaskell.hs @@ -0,0 +1,362 @@ +module EHaskell ( + parseAll +, getImportsSrcDst +, copyIfSrcExist + +, haskellSffx +, getEhsDir + +, processOptionEhs +, exitIfFail + +, CodePos(..) -- FOR TEST +, parseEHaskell -- FOR TEST +, getSrcAndImports -- FOR TEST +, notOverwrided -- FOR TEST +) where + +import System.Directory (copyFile, doesFileExist) +import System.Directory.Tools (doesNotExistOrOldThan) +import System.Exit (ExitCode(ExitSuccess), exitWith) +import System.FilePath (takeDirectory) +import Control.Monad (unless) +import Control.Monad.Tools (whenM, skipRet) +import Control.Applicative ((<$>)) +import Text.ParserCombinators.MTLParse + (MonadPlus, Parse, runParse, evalParse, + spot, spotBack, token, tokenBack, tokens, parseNot, still, + optional, list, greedyList, neList, greedyNeList, + mplus, endOfInput) +import Data.Char (isSpace, isUpper, isLower, isDigit) +import Data.Function.Tools (applyUnless) +import Data.List (isPrefixOf) +import Prelude hiding (readFile, writeFile) +import Text.RegexPR (getbrsRegexPR) + +ehaskellDir, haskellSffx, ehsHandleStr, putStrStr :: String +ehaskellDir = "_ehs/" +haskellSffx = ".hs" +ehsHandleStr = "_ehs_handle" +putStrStr = "(modify . flip (++))" -- "hPutStr " ++ ehsHandleStr + +getEhsDir :: FilePath -> FilePath +getEhsDir inFl = let d = takeDirectory inFl + in applyUnless (null d) ((d ++ "/") ++) ehaskellDir + +data CodePos = Import | Top | Definition | Inner deriving (Eq, Enum, Show) + +exitIfFail :: IO ExitCode -> IO () +exitIfFail act = do + ec <- act + unless (ec == ExitSuccess) $ exitWith ec + +getImportsSrcDst :: FilePath -> String -> (FilePath, FilePath) +getImportsSrcDst dir src = head $ evalParse (copyImportsParse dir) ("", src) + +copyIfSrcExist :: FilePath -> FilePath -> IO () +copyIfSrcExist src dst + = whenM (doesFileExist src) $ whenM (doesNotExistOrOldThan dst src) $ + copyFile src dst + +copyImportsParse :: String -> Parse Char (FilePath, FilePath) +copyImportsParse dir = do + tokens "import" + neList $ spot $ isSpace + mn <- neList (spot $ \c -> not (isSpace c) && notElem c "()") >>= skipRet (still (spot $ \c -> isSpace c || elem c "(%") `mplus` endOfInput ' ') + list $ spot isSpace + optional parseParenthesis + list $ spot isSpace + endOfInput () + let sfn = mn ++ ".hs" + dfn = dir ++ sfn + return (sfn, dfn) + +processOptionEhs :: [String] -> ([String], Maybe String, String) +processOptionEhs args + = let (eqs, args_) = (takeOptionEq args, dropOptionEq args) + (outfile, [infile]) = (takeOptionO args_, dropOptionO args_) + in (eqs, outfile, infile) + +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, parseNotOnlyEq + :: Parse Char String +parseParenthesis, parseInner, parseLet :: Parse Char String +parseImport, parseDef, parseTop :: Parse Char (CodePos, String) +parseEHaskell, parseApply :: Parse Char [ (CodePos, String) ] +parseText, parseN, parseEq, parseEqEq, parseEqShow, parseEqEqShow + :: Parse Char (CodePos, String) +parseApplyBegin, parseApplyContinue, parseApplyEnd, parseVarid, parseAssigned + :: Parse Char String +mkOutputText, mkOutputTop, mkOutputHere, mkOutputLet, + 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, " do {\n"):) + . (++[(Inner, " hClose " ++ ehsHandleStr ++ " }\n")]) + . (++ [(Inner, " } `runStateT` \"\" >>= hPutStr " ++ ehsHandleStr ++ " . snd;\n")]) + . ((Import, "import Control.Monad.State (runStateT, modify, lift)\n"):) + . ((Import, "import System.IO (stdout, openFile, IOMode(WriteMode), hClose)\n"):) + . ((Import, "import System.IO.UTF8 (hPutStr)\n"):) + . ((Import, "import System.Environment (getArgs)\n"):) ) + <$> parseEHaskell >>= endOfInput + +getHandleStr = " " ++ ehsHandleStr ++ + " <- getArgs >>= (\\args -> " ++ + "if null args then return stdout else openFile (head args) WriteMode);\n" + +parseEHaskell = concat <$> + ( greedyList $ (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 = ((:[]) <$>) + +getSrcAndImports :: [ (CodePos, String) ] -> (String, [String]) +getSrcAndImports lst = (myConcat lst, map snd $ filter ((==Import).fst) $ lst) + +notOverwrided :: [ String ] -> (CodePos, String) -> Bool +notOverwrided eqs (Definition, def) + = (fst $ head $ runParse parseAssigned $ ("", def)) `notElem` + map (fst . head . runParse parseAssigned . (,) "") eqs +notOverwrided _ _ = True + +parseAssigned = mplus parseVarid $ do + token '(' + op <- neList $ spot isAscSymbol + token ')' + return $ '(' : op ++ ")" + +myConcat :: (Eq e, Enum e) => [ (e, [a]) ] -> [a] +myConcat 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 `mplus` parseLet + still (parseNot () $ tokenBack '-') + tokens "%>" + if isPrefixOf "let " code + then return $ (Inner, mkOutputLet code) + else return $ (Inner, mkOutputHere code) + +parseLet = do + list $ spot isSpace + tokens "let" + list $ spot isSpace + token '{' + list $ spot isSpace + assnd <- parseAssigned + list $ spot isSpace + token '=' + list $ spot isSpace + innr <- parseInner + still $ do + list $ spotBack isSpace + tokenBack '}' + list $ spot isSpace + return $ "let { " ++ assnd ++ " = " ++ innr + +parseEq = do + tokens "<%=" >> still (parseNot () $ spot $ flip elem "=$") + code <- parseInner + tokens "%>" + return $ (Inner, mkOutputReturnCode code) + +parseEqEq = do + tokens "<%==" >> still (parseNot () $ token '$') + code <- parseInner + still (parseNot () $ tokenBack '-') + 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 <$> parseEHaskell + cs <- list $ do + ci <- parseApplyContinue + t <- surround <$> parseEHaskell + return $ (Inner, ci) : t + e <- parseApplyEnd + return $ (Inner, "lift (") : (Inner, b) : c ++ concat cs ++ [(Inner, e)] ++ + [(Inner, ") >>= ")] ++ [(Inner, putStrStr)] ++ [(Inner, ";\n")] + where + surround = ( ++ [ (Inner, " } `runStateT` \"\")") ] ).( (Inner, "(fmap snd $ 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 + `mplus` + parseNotOnlyEq + +parseInnerPlain = neList $ do + still (parseNot () $ tokens "%>") + still (parseNot () $ tokens "-%>") + still (parseNot () $ tokens "%%>") + spot (flip notElem "\"(=") + +parseNotOnlyEq + = (spot isAscSymbol >>= skipRet (token '=') >>= (return . (:"="))) + `mplus` + (token '=' >> spot isAscSymbol >>= return . ('=':) . (:[])) + +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" +mkOutputImport _ _ = error "mkOutputImport import should single" +mkOutputDef var val = var ++ "= " ++ val ++ ";\n" +mkOutputTop code = code ++ ";\n" +mkOutputLet code = " " ++ code ++ ";\n" +mkOutputHere code + = case getbrsRegexPR "^\\s*(\\S+)\\s*<-(.+)" code of + (_:brs) -> " " ++ (brs !! 0) ++ " <- lift $ " ++ (brs !! 1) ++ ";\n" + [] -> " lift $ " ++ code ++ ";\n" +mkOutputCode code = " lift (" ++ code ++ ") >>= " ++ putStrStr ++ ";\n" +mkOutputShowCode code = " lift (" ++ code ++ ") >>= " ++ putStrStr ++ ". show ;\n" +mkOutputReturnCode code = " " ++ putStrStr ++ " $ (" ++ code ++ ") ;\n" +mkOutputReturnShowCode code = " " ++ putStrStr ++ " $ show (" ++ code ++ ") ;\n" diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,320 +1,38 @@ -{-# OPTIONS_GHC -XFlexibleContexts #-} module Main where +import EHaskell (parseAll, copyIfSrcExist, getImportsSrcDst, + processOptionEhs, + getEhsDir, haskellSffx, exitIfFail) import System.Environment (getArgs) -import System.Directory (doesDirectoryExist, createDirectory, copyFile, doesFileExist) -import System.Directory.Tools (doesNotExistOrOldThan) +import System.IO (stderr) +import System.Directory (doesDirectoryExist, createDirectory) +import System.FilePath (takeFileName) +import System.Exit (exitFailure) 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 Prelude hiding (readFile, writeFile) +import System.IO.UTF8 (readFile, writeFile, hPutStr) import Control.Applicative ((<$>)) +import Control.Monad.Tools (unlessM) +import Data.Maybe (maybeToList) +import YJTools.Tribial (ghcMake) 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) + (Parse, runParse) 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 + (eqs, outfile, infile) <- processOptionEhs <$> getArgs + let edir = getEhsDir infile + 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" + [] -> hPutStr stderr "parse error" >> exitFailure + (((p,ips),_):_) -> do + writeFile srcFile p + mapM_ (uncurry copyIfSrcExist . getImportsSrcDst edir) ips + exitIfFail $ ghcMake exeName edir + exitIfFail $ runProcess exeFile (maybeToList outfile) + Nothing Nothing Nothing Nothing Nothing >>= waitForProcess diff --git a/ehaskell.cabal b/ehaskell.cabal --- a/ehaskell.cabal +++ b/ehaskell.cabal @@ -1,5 +1,5 @@ Name: ehaskell -Version: 0.5 +Version: 0.6 Cabal-Version: >= 1.2 Build-Type: Simple License: GPL @@ -44,6 +44,6 @@ Executable ehs Main-Is: Main.hs + Other-Modules: EHaskell Build-Depends: base, mtlparse >= 0.0.1, yjtools >= 0.8, directory, regexpr >= 0.3.3, process, filepath, utf8-string GHC-Options: -Wall - Extensions: FlexibleContexts