ehaskell 0.5 → 0.6
raw patch · 3 files changed
+390/−310 lines, 3 files
Files
- EHaskell.hs +362/−0
- Main.hs +26/−308
- ehaskell.cabal +2/−2
+ EHaskell.hs view
@@ -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"
Main.hs view
@@ -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
ehaskell.cabal view
@@ -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