ehaskell-0.7: MkCode.hs

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"