ehaskell-0.6: EHaskell.hs

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"