{-# OPTIONS_GHC -XFlexibleContexts #-}
module Main where

import System.Environment     (getArgs)
import System.Directory       (doesDirectoryExist, createDirectory, copyFile, doesFileExist)
import System.Directory.Tools (doesNotExistOrOldThan)
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 Control.Applicative    ((<$>))
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)

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
  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"