packages feed

ehaskell 0.6 → 0.7

raw patch · 7 files changed

+375/−377 lines, 7 files

Files

EHaskell.hs view
@@ -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
+ EHaskellTools.hs view
@@ -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
+ GetCodeText.hs view
@@ -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 ++ ")"
Main.hs view
@@ -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)
+ MkCode.hs view
@@ -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"
+ Types.hs view
@@ -0,0 +1,9 @@+module Types (+  CodeText(..)+) where++data CodeText+  = Text+  | Code   | CodeTop  | CodeBegin  | CodeCont | CodeEnd+  | CodeEq | CodeEqEq | CodeEqShow | CodeEqEqShow+  deriving (Show, Eq)
ehaskell.cabal view
@@ -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