diff --git a/EHaskell.hs b/EHaskell.hs --- a/EHaskell.hs +++ b/EHaskell.hs @@ -1,362 +1,129 @@ module EHaskell ( - parseAll -, getImportsSrcDst -, copyIfSrcExist - -, haskellSffx -, getEhsDir - -, processOptionEhs -, exitIfFail - -, CodePos(..) -- FOR TEST -, parseEHaskell -- FOR TEST -, getSrcAndImports -- FOR TEST -, notOverwrided -- FOR TEST + mkEhsSrc ) 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) +import Data.Char (isSpace, isAlphaNum) +import Data.Bool.Tools ((|||)) +import Control.Monad.Tools (skipRet) +import Text.ParserCombinators.MTLParse (Parse, runParse, spot, token, tokens, + mplus, list, neList, optional, + endOfInput, still, + parseNot) +import Types (CodeText(..)) +import MkCode (arrangeCode, mkSrcText, mkSrcCode, + mkSrcBegin, mkSrcCont, mkSrcEnd, + mkSrcImport, mkSrcDefinition, mkSrcTop, + mkSrcEq, mkSrcEqEq, mkSrcEqShow, mkSrcEqEqShow) +import GetCodeText (getCodeText) -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) +data CodePos = Import { getModName :: String } | Top | + Definition { getVar :: String } | Inner + deriving (Eq, Show) +isImport, isDefinition :: CodePos -> Bool +isImport (Import _) = True +isImport _ = False +isDefinition (Definition _) = True +isDefinition _ = False -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 +mkEhsSrc :: [ (String, String) ] -> String -> (String, [String]) +mkEhsSrc defs src + = let posSrcPair = fst $ myHead $ runParse parsePairAll ([], getCodeText src) + importSrc = concat $ mLookupBy isImport posSrcPair + defSrc = concat (map snd $ deleteDef (map fst defs) posSrcPair) ++ + unlines (map (\(var, val) -> var ++ " = " ++ val) defs) + topSrc = concat $ mLookup Top posSrcPair + innerSrc = concat $ mLookup Inner posSrcPair + mods = map getModName $ filter isImport $ map fst posSrcPair + in (arrangeCode (importSrc ++ defSrc ++ topSrc) innerSrc, mods) + where myHead (h:_) = h + myHead _ = error "parsePairAll in EHaskellNew module: parse error" -parseEq = do - tokens "<%=" >> still (parseNot () $ spot $ flip elem "=$") - code <- parseInner - tokens "%>" - return $ (Inner, mkOutputReturnCode code) +deleteDef :: [ String ] -> [ (CodePos, String) ] -> [ (CodePos, String) ] +deleteDef vars pairs = filter (flip notElem vars . getVar . fst) $ + filter (isDefinition . fst ) pairs -parseEqEq = do - tokens "<%==" >> still (parseNot () $ token '$') - code <- parseInner - still (parseNot () $ tokenBack '-') - tokens "%>" - return $ (Inner, mkOutputCode code) +parsePairAll, parsePair :: Parse (CodeText, String) [ (CodePos, String) ] +parsePairAll + = parsePair >>= endOfInput +parsePair + = fmap concat $ list $ parsePairText `mplus` parsePairCode `mplus` + parsePairTop `mplus` parsePairApply `mplus` + parsePairEq `mplus` parsePairEqEq `mplus` + parsePairEqShow `mplus` parsePairEqEqShow -parseEqShow = do - tokens "<%=$" - code <- parseInner - tokens "%>" - return $ (Inner, mkOutputReturnShowCode code) +parsePairText, parsePairCode, parsePairTop, parsePairApply, + parsePairEq, parsePairEqEq, parsePairEqShow, parsePairEqEqShow + :: Parse (CodeText, String) [ (CodePos, String) ] +parsePairText = do + (_, src) <- spot ((==Text).fst) + return [ (Inner, mkSrcText src) ] +parsePairCode = do + (_, src) <- spot ((==Code).fst) + return [ (Inner, mkSrcCode src) ] +parsePairTop = do + (_, src) <- spot ((==CodeTop).fst) + return [ makeIDT src ] +parsePairApply = do + (_, srcB) <- spot ((==CodeBegin).fst) + pcf <- parsePair + pcs <- fmap concat $ list $ do + (_, srcC) <- spot ((==CodeCont).fst) + pcsGen <- parsePair + return $ (Inner, mkSrcCont srcC) : pcsGen + (_, srcE) <- spot ((==CodeEnd).fst) + return $ (Inner, mkSrcBegin srcB) : pcf ++ pcs ++ [ (Inner, mkSrcEnd srcE) ] +parsePairEq = do + (_, src) <- spot ((==CodeEq).fst) + return $ [ (Inner, mkSrcEq src) ] +parsePairEqShow = do + (_, src) <- spot ((==CodeEqShow).fst) + return $ [ (Inner, mkSrcEqShow src) ] +parsePairEqEq = do + (_, src) <- spot ((==CodeEqEq).fst) + return $ [ (Inner, mkSrcEqEq src) ] +parsePairEqEqShow = do + (_, src) <- spot ((==CodeEqEqShow).fst) + return $ [ (Inner, mkSrcEqEqShow src) ] -parseEqEqShow = do - tokens "<%==$" - code <- parseInner - tokens "%>" - return $ (Inner, mkOutputShowCode code) +makeIDT :: String -> ( CodePos, String ) +makeIDT = fst . myHead . runParse parseIDT . (,) "" + where myHead (h:_) = h + myHead _ = error "parseIDT in EHaskellNew: parse error" +parseIDT, parseImport, parseDefinition, parseTop + :: Parse Char ( CodePos, String ) +parseIDT = parseImport `mplus` parseDefinition `mplus` parseTop parseImport = do - tokens "<%%" list $ spot isSpace tokens "import" - list $ spot isSpace - mn <- neList (spot $ not . isSpace) >>= skipRet (still $ spot $ isSpace) + neList $ spot isSpace + mdl <- list $ spot $ isAlphaNum ||| flip elem "." + imps <- fmap concat $ optional $ do + list $ spot isSpace + token '(' + list (spot $ const True) >>= skipRet (token ')') list $ spot isSpace - ips <- optional parseParenthesis + endOfInput () + return (Import mdl, mkSrcImport mdl imps) +parseDefinition = do list $ spot isSpace - tokens "%%>" - return $ (Import, mkOutputImport mn ips) - -parseDef = do - tokens "<%%" - var <- parseInner + var <- list (spot isVarChar) >>= skipRet (still $ spot $ not . isVarChar) list $ spot isSpace - token '=' + token '=' >> still (spot $ not . isSymbol) 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")] + val <- list (spot $ const True) >>= endOfInput + return (Definition var, mkSrcDefinition var val) 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 ++ ")" + isVarChar = isAlphaNum ||| flip elem "_" + isSymbol = flip elem "!#$%&*+./<=>?@\\^|-~" +parseTop = do + still $ parseNot () $ parseImport `mplus` parseDefinition + list (spot isSpace) >> still (spot $ not . isSpace) + src <- list (spot $ const True) >>= endOfInput + return (Top, mkSrcTop src) -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 == '\'' +mLookup :: Eq a => a -> [ (a, b) ] -> [ b ] +mLookup x ps = map snd $ filter ((x==).fst) ps -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" +mLookupBy :: (a -> Bool) -> [ (a, b) ] -> [ b ] +mLookupBy p ps = map snd $ filter (p . fst) ps diff --git a/EHaskellTools.hs b/EHaskellTools.hs new file mode 100644 --- /dev/null +++ b/EHaskellTools.hs @@ -0,0 +1,88 @@ +module EHaskellTools ( + createEhsDir +, copyModuleFile +, writeCode +, makeExe +, runExe +, processOptionEhs +) where + +import System.Directory (createDirectory, doesDirectoryExist, copyFile, + doesFileExist) +import System.FilePath (takeDirectory, takeFileName) +import System.Process (runProcess, waitForProcess) +import System.Exit (ExitCode(ExitSuccess), exitWith) +import Data.Maybe (maybeToList) +import Data.Function.Tools(applyUnless, apply2way) +import Control.Monad (unless) +import Control.Monad.Tools(unlessM, whenM) +import Text.RegexPR (gsubRegexPR) +import YJTools.Tribial (ghcMake) + +addDir :: FilePath -> FilePath -> FilePath +addDir dir fp = applyUnless (null dir) ((dir ++ "/") ++) fp + +edir :: FilePath -> FilePath +edir infile = let d = takeDirectory infile + in applyUnless (null d) ((d ++ "/") ++) "_ehs/" + +createEhsDir :: FilePath -> IO () +createEhsDir = apply2way unlessM doesDirectoryExist createDirectory . edir + +copyModuleFile :: FilePath -> String -> IO () +copyModuleFile infile modName + = let dir = takeDirectory infile + src = addDir dir $ modName ++ ".hs" + in whenM (doesFileExist src) $ + copyFile src (edir infile ++ modName ++ ".hs") + +writeCode :: FilePath -> String -> IO () +writeCode infile code = do + let exeName = gsubRegexPR "\\." "_" $ takeFileName infile + srcFile = edir infile ++ exeName ++ ".hs" + writeFile srcFile code + +makeExe :: FilePath -> IO () +makeExe infile = do + let exeName = gsubRegexPR "\\." "_" $ takeFileName infile + exitIfFail $ ghcMake exeName $ edir infile + +runExe :: FilePath -> Maybe FilePath -> IO () +runExe infile outfile = do + let exeName = gsubRegexPR "\\." "_" $ takeFileName infile + exeFile = edir infile ++ exeName + exitIfFail $ runProcess exeFile (maybeToList outfile) Nothing Nothing Nothing Nothing Nothing + >>= waitForProcess + +exitIfFail :: IO ExitCode -> IO () +exitIfFail act = do + ec <- act + unless (ec == ExitSuccess) $ exitWith ec + +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 diff --git a/GetCodeText.hs b/GetCodeText.hs new file mode 100644 --- /dev/null +++ b/GetCodeText.hs @@ -0,0 +1,75 @@ +module GetCodeText ( + getCodeText +, CodeText(..) +) where + +import Text.ParserCombinators.MTLParse +import Control.Monad.Tools +import Types + +type SymCodePair = ( (String, String), CodeText ) + +symCodePairs :: [ SymCodePair ] +symCodePairs = [ + ( ("" , "" ), Code ) + , ( ("%" , "%"), CodeTop ) + , ( ("" , "-"), CodeBegin ) + , ( ("-" , "-"), CodeCont ) + , ( ("-" , "" ), CodeEnd ) + , ( ("=" , "" ), CodeEq ) + , ( ("==" , "" ), CodeEqEq ) + , ( ("=$" , "" ), CodeEqShow ) + , ( ("==$", "" ), CodeEqEqShow ) + ] + +getCodeText :: String -> [ (CodeText, String) ] +getCodeText = fst . myHead . runParse parseCodeText . (,) "" + where + myHead (h:_) = h + myHead _ = error "parseCodeText in module GetCodeText: parse error" + +parseCodeText :: Parse Char [ (CodeText, String) ] +parseCodeText + = ( fmap concat $ list $ parseText >:> (fmap (:[]) parseCode) ) >++> + (fmap (:[]) parseText) >>= endOfInput + +parseText :: Parse Char (CodeText, String) +parseText = do + txt <- list $ do + still (parseNot () $ tokens "<%") + spot $ const True + return (Text, txt) + +parseCode :: Parse Char (CodeText, String) +parseCode = + (tokens "<%" >> msum (map parseCodeGen symCodePairs) >>= skipRet (tokens "%>")) + `mplus` (tokens "<%-%>" >> return (CodeEnd, "")) + `mplus` (tokens "<%--%>" >> return (CodeCont, "")) + +parseCodeGen :: SymCodePair -> Parse Char (CodeText, String) +parseCodeGen ((b, e), c) = do + tokens b + still $ spot $ flip notElem "%-=$" + code <- fmap concat $ list $ + do { still (parseNot () $ tokens "%>"); + fmap (:[]) $ spot $ flip notElem "()\""; } + `mplus` parseDQ `mplus` parseParen + still $ spotBack (/='-') + tokens e + return (c, code) + +parseDQ :: Parse Char String +parseDQ = do + token '"' + ret <- fmap concat $ list $ (fmap (:[]) $ spot $ flip notElem "\\\"") `mplus` + (token '\\' >:> (fmap (:[]) $ spot $ const True)) + token '"' + return $ '"' : ret ++ "\"" + +parseParen :: Parse Char String +parseParen = do + token '(' + ret <- fmap concat $ list $ ( fmap (:[]) $ spot $ flip notElem "()" ) + `mplus` parseParen + token ')' + return $ '(' : ret ++ ")" diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,38 +1,25 @@ module Main where -import EHaskell (parseAll, copyIfSrcExist, getImportsSrcDst, - processOptionEhs, - getEhsDir, haskellSffx, exitIfFail) -import System.Environment (getArgs) -import System.IO (stderr) -import System.Directory (doesDirectoryExist, createDirectory) -import System.FilePath (takeFileName) -import System.Exit (exitFailure) -import System.Process (runProcess, waitForProcess) -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 - (Parse, runParse) +import System.Environment (getArgs) +import EHaskell (mkEhsSrc) +import EHaskellTools (createEhsDir, copyModuleFile, writeCode, makeExe, + runExe, processOptionEhs) +import Data.List.Tools (dropUntil) +import Control.Applicative((<$>)) main :: IO () main = do +-- args <- getArgs (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" >> 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 + let -- infile = head $ filter (notElem '=') args + defs = filter (elem '=') eqs + cont <- readFile infile + let (src,mods) = mkEhsSrc (map splitAtEq defs) cont + mapM_ (copyModuleFile infile) mods + createEhsDir infile + writeCode infile src + makeExe infile + runExe infile outfile + +splitAtEq :: String -> (String, String) +splitAtEq str = (takeWhile (/='=') str, dropUntil (=='=') str) diff --git a/MkCode.hs b/MkCode.hs new file mode 100644 --- /dev/null +++ b/MkCode.hs @@ -0,0 +1,72 @@ +module MkCode ( + arrangeCode +, mkSrcText +, mkSrcCode +, mkSrcBegin +, mkSrcCont +, mkSrcEnd +, mkSrcImport +, mkSrcDefinition +, mkSrcTop +, mkSrcEq +, mkSrcEqEq +, mkSrcEqShow +, mkSrcEqEqShow +) where + +import Text.RegexPR (getbrsRegexPR) + +arrangeCode :: String -> String -> String +arrangeCode top inner = mkImports imports ++ top ++ header ++ inner ++ footer + +mkImports :: [ String ] -> String +mkImports = (++"\n") . unlines . map ("import "++) + +imports :: [ String ] +imports = [ + "System.Environment (getArgs)" + , "System.IO (hPutStr, stdout, openFile, hClose, IOMode(WriteMode))" + , "Control.Monad.State(runStateT, modify, lift)" + ] + +header, footer, putStrStr :: String +putStrStr + = "(\\stm -> do {\n" ++ + " __ehs_handle <- getArgs >>= (\\args -> if null args\n" ++ + " then return stdout\n" ++ + " else openFile (head args) WriteMode);\n" ++ + " runStateT stm \"\" >>= hPutStr __ehs_handle . snd;\n" ++ + " hClose __ehs_handle }) $ " +header = "main = " ++ putStrStr ++ "do {\n" +footer = " }\n" + +mkSrcText :: String -> String +mkSrcText txt = " " ++ "(modify . flip (++))" ++ " $ " ++ show txt ++ ";\n" + +mkSrcCode :: String -> String +mkSrcCode code + = case (getbrsRegexPR "^\\s*(\\S+)\\s*<-(.+)$" code, + getbrsRegexPR "^\\s*let\\s+(.+)$" code) of + ((_:brs), _) -> " " ++ (brs !! 0) ++ " <- lift $ " ++ (brs !! 1) ++ ";\n" + (_, (_:brs)) -> " let " ++ (brs !! 0) ++ ";\n" + _ -> " lift $ " ++ code ++ ";\n" + +mkSrcBegin, mkSrcCont, mkSrcEnd, mkSrcTop, + mkSrcEq, mkSrcEqEq, mkSrcEqShow, mkSrcEqEqShow + :: String -> String +mkSrcBegin b = " lift ( " ++ b ++ " (fmap snd $ flip runStateT \"\" $ do {\n" +mkSrcCont c = " }) " ++ c ++ " (fmap snd $ flip runStateT \"\" $ do {\n" +mkSrcEnd e = " }) " ++ e ++ " ) >>= (modify . flip (++));\n" + +mkSrcImport :: String -> String -> String +mkSrcImport mdl "" = "import " ++ mdl ++ "\n" +mkSrcImport mdl imps = "import " ++ mdl ++ "(" ++ imps ++ ")\n" + +mkSrcDefinition :: String -> String -> String +mkSrcDefinition var val = var ++ " = " ++ val ++ "\n" + +mkSrcTop = (++"\n") +mkSrcEq src = " (modify . flip (++)) $ " ++ src ++ ";\n" +mkSrcEqShow src = " (modify . flip (++)) $ show $ " ++ src ++ ";\n" +mkSrcEqEq src = " lift (" ++ src ++ ") >>= (modify . flip (++));\n" +mkSrcEqEqShow src = " lift (" ++ src ++ ") >>= (modify . flip (++)) . show;\n" diff --git a/Types.hs b/Types.hs new file mode 100644 --- /dev/null +++ b/Types.hs @@ -0,0 +1,9 @@ +module Types ( + CodeText(..) +) where + +data CodeText + = Text + | Code | CodeTop | CodeBegin | CodeCont | CodeEnd + | CodeEq | CodeEqEq | CodeEqShow | CodeEqEqShow + deriving (Show, Eq) diff --git a/ehaskell.cabal b/ehaskell.cabal --- a/ehaskell.cabal +++ b/ehaskell.cabal @@ -1,5 +1,5 @@ Name: ehaskell -Version: 0.6 +Version: 0.7 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 + Other-Modules: MkCode, EHaskellTools, Types, EHaskell, GetCodeText GHC-Options: -Wall + Build-Depends: base, mtlparse >= 0.0.1, yjtools >= 0.8, directory, regexpr >= 0.3.3, process, filepath, utf8-string