module MkCode (
  mkCode
) where

import Data.Char    (isSpace)
import Text.RegexPR (getbrsRegexPR)
import Types        (CodeText(..), CodeTextStr, CodeGen(..))

mkCode :: CodeGen -> String
mkCode (CodeGen impGen topGen defGen inners)
  = arrangeCode ( concat $ map (uncurry mkSrcImport) impGen ++
                           map mkSrcTop topGen              ++
		           map (uncurry mkSrcDef) defGen     )
		( concatMap mkSrcInner inners )

mkSrcInner :: CodeTextStr -> String
mkSrcInner (Text        , s) = mkSrcText     s
mkSrcInner (Code        , s) = mkSrcCode     s
mkSrcInner (CodeBegin   , s) = mkSrcBegin    s
mkSrcInner (CodeCont    , s) = mkSrcCont     s
mkSrcInner (CodeEnd     , s) = mkSrcEnd      s
mkSrcInner (CodeEq      , s) = mkSrcEq       s
mkSrcInner (CodeEqShow  , s) = mkSrcEqShow   s
mkSrcInner (CodeEqEq    , s) = mkSrcEqEq     s
mkSrcInner (CodeEqEqShow, s) = mkSrcEqEqShow s
mkSrcInner _                 = error "Can't occur"

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          (stdout, openFile, hClose, IOMode(WriteMode))"
 , "System.IO.UTF8     (hPutStr)"
 , "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"

addStrStr :: String
addStrStr = "(modify . flip (++))"

mkSrcText :: String -> String
mkSrcText txt = "  " ++ addStrStr ++ " $ " ++ show txt ++ ";\n"

mkSrcCode, mkSrcBegin, mkSrcCont, mkSrcEnd, mkSrcTop,
  mkSrcEq, mkSrcEqEq, mkSrcEqShow, mkSrcEqEqShow :: String -> String

mkSrcCode code
  = case (getbrsRegexPR "(?m)^\\s*(\\S+)\\s*<-(.+)$" code,
          getbrsRegexPR "(?m)^\\s*let\\s+(.+)$" code) of
         ((_:brs), _) -> "  " ++ (brs !! 0) ++ " <- lift $ " ++ (brs !! 1) ++ ";\n"
	 (_, (_:brs)) -> "  let " ++ (brs !! 0) ++ ";\n"
	 _            -> "  lift $ " ++ code ++ ";\n"

mkSrcBegin b = "  lift ( " ++ b ++ " (fmap snd $ flip runStateT \"\" $ do {\n"
mkSrcCont  c = "  }) " ++ c ++ " (fmap snd $ flip runStateT \"\" $ do {\n"
mkSrcEnd   e = "  }) " ++ e ++ " ) >>= " ++ addStrStr ++ ";\n"

mkSrcImport :: String -> String -> String
mkSrcImport mdl ""   = "import " ++ mdl ++ "\n"
mkSrcImport mdl imps = "import " ++ mdl ++ "(" ++ imps ++ ")\n"

mkSrcDef :: String -> String -> String
mkSrcDef var val = var ++ " = " ++ val ++ "\n"

mkSrcTop          = (++"\n") . dropWhile isSpace
mkSrcEq src       = "  " ++ addStrStr ++ " $ " ++ src ++ ";\n"
mkSrcEqShow src   = "  " ++ addStrStr ++ " $ show $ " ++ src ++ ";\n"
mkSrcEqEq src     = "  lift (" ++ src ++ ") >>= " ++ addStrStr ++ ";\n"
mkSrcEqEqShow src = "  lift (" ++ src ++ ") >>= " ++ addStrStr ++ " . show;\n"