content: -- 
  -- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons
  -- 
  -- This program is free software; you can redistribute it and/or
  -- modify it under the terms of the GNU General Public License as
  -- published by the Free Software Foundation; either version 2 of
  -- the License, or (at your option) any later version.
  -- 
  -- This program is distributed in the hope that it will be useful,
  -- but WITHOUT ANY WARRANTY; without even the implied warranty of
  -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  -- General Public License for more details.
  -- 
  -- You should have received a copy of the GNU General Public License
  -- along with this program; if not, write to the Free Software
  -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  -- 02111-1307, USA.
  -- 
  
  --
  -- the top level. This is the h4sh 'compiler'
  --
  
  import Command
  
  import Data.List
  import System.Cmd
  import Text.PrettyPrint
  import System.Exit
  import System.Environment
  
  version :: [Char]
  version = "0.3"
  
  data IOMode = MPack | MList
      deriving Eq
  
  --
  -- create all src files, and a .cabal file
  --
  main :: IO ()
  main = do
          args <- getArgs
          let flag = case args of
                  ["list"]   -> Just MList
                  ["clean"]  -> Nothing
                  _          -> Just MPack  -- default
          case flag of
              Just f  -> do mapM_ (build f) commands
                            makeCabal f commands
              _       -> mapM_ clean commands
  
        where
          clean (Command _ f _ _ _) =
                system $ "rm -rf " ++ (concat. intersperse " ")
                                  [f,f++".hi",f++".hs",f++".o",f++"*~"]
  
  ------------------------------------------------------------------------
  --
  -- generate a src module with the appropriate wrapper over the function
  --
  build b c@(Command _ r _ _ _) = writeFile (r++".hs") (generate c b)
  
  --
  -- generate a h4sh.cabal file
  --
  makeCabal :: IOMode -> [Command] -> IO ()
  makeCabal iomode cs = writeFile "h4sh.cabal" $ unlines $
    [ "Name:                h4sh"
    , "Version:             " ++ version
    , "License:             GPL"
    , "License-file:        LICENSE"
    , "Author:              Don Stewart"
    , "Maintainer:          dons@cse.unsw.edu.au"
    , "Build-Depends:       base >= 4, hint, regex-compat, bytestring"
    , "Exposed-modules:     H4SH.List"
    , "Build-Type:          Simple"
    , ""
    ] ++ map (executable iomode) cs
  
  executable :: IOMode -> Command -> String
  executable mode (Command _ n _ _ _) = unlines $
    [ "executable:          " ++ n
    , "main-is:             " ++ n ++ ".hs"
    , "ghc-options:         -O2 -funbox-strict-fields -fglasgow-exts -threaded -dynamic" ]
  
  ------------------------------------------------------------------------
  --
  -- Top level
  --
  generate :: Command -> IOMode -> String
  generate c@(Command n r ty mode help) iomode = unlines $
    [ "import System.Console.GetOpt"
    , "import System.Environment"
    , "import Control.Monad"
    , "import System.Exit"
    , "import Data.List"
    , unlines $ case mode of
          List -> []
          _ | iomode == MList -> []
            | otherwise       -> ["import System.IO (stdout,stdin)"
                                ,"import qualified Data.ByteString.Char8 as P"]
    , ""
    , render (needsEval ty)
    , ""
    , "version = \"Haskell " ++ r ++ " " ++ version ++ "\""
    , ""
    , "help = " ++ show (unlines help)
    , ""
    , case mode of
          List -> "run f = " ++ render (doRun (dropArgs ty))
          _ | iomode == MList -> "run f = " ++ render (doRun (dropArgs ty))
            | otherwise       -> "runPS f = " ++ render (doRawRun (dropArgs ty))
    , ""
    , "main = do"
    , " args   <- getArgs"
    , " (_,fs) <- parseArgs args"
    , unlines $  case mode of 
          List ->               [ doArgs ty , " putStr $ run " ++ 
                                  render (parens $ doApp n ty) ++ " input" ]
  
          _ | iomode == MList-> [ doArgs ty , " putStr $ run " ++ 
                                  render (parens $ doApp n ty) ++ " input" ]
  
            | otherwise      -> [ doRawArgs ty (psMode iomode)
                                  ("P.putStr ((runPS " ++ 
                                  (render (parens (doApp n ty)) ++ ") input)")) ]
    , ""
    , parseArgs c
    ]
  
    where
        psMode MPack = "P.readFile"
        psMode _     = error "psMode: using packed string with list IO!"
  
  ------------------------------------------------------------------------
  -- work out how to apply arguments to function
  --
  doApp :: String -> Type -> Doc
  doApp n (_ `To` (_ `To` _))  = text n <+> char 'a'
  doApp n (_ `To` _)           = text n
  
  -- ---------------------------------------------------------------------
  --
  -- We've already applied all but the last argument, now, based on the
  -- final argument and the return type, work out how to run this function
  -- on its input.
  --
  doRun :: Type -> Doc
  doRun (LS `To` LI) = text "unlines . (map show) . f . lines"
  doRun (LS `To` I)  = text "(++ ['\\n']) . show . f . lines" 
  doRun (LS `To` S)  = text "(++ ['\\n']) . f . lines"
  doRun (LS `To` LS) = text "unlines . f . lines"
  doRun (S  `To` LS) = text "unlines . f"
  doRun (S  `To` S)  = text "f"
  
  ------------------------------------------------------------------------
  
  doRawRun :: Type -> Doc
  doRawRun (LS `To` S)  = text "(\\x -> P.append x (P.pack \"\\n\")) . f .  P.lines"
  doRawRun (LS `To` I)  = text "P.pack . (++ ['\\n']) . show . f . P.lines"
  doRawRun (LS `To` LS) = text "P.unlines . f . P.lines"
  doRawRun (S  `To` LS) = text "P.unlines . f"
  doRawRun (S  `To` S)  = text "f"
  
  ------------------------------------------------------------------------
  
  dropArgs :: Type -> Type
  dropArgs (_ `To` t@(_ `To` _)) = t
  dropArgs t = t
  
  ------------------------------------------------------------------------
  --
  -- Only import System.Eval for binaries that actually need it
  --
  needsEval :: Type -> Doc
  needsEval ((_ `To` _) `To` (_ `To` _)) = text "import Language.Haskell.Interpreter"
  needsEval _ = empty
  
  ------------------------------------------------------------------------
  --
  -- Collect arguments from the command line
  -- todo, drop return type, implement pretty instance
  --
  doArgs :: Type -> String
  doArgs ((S `To` (MaybeT _)) `To` _)   = createEvalandArg "String -> Maybe (String,String)"
  doArgs ((S `To` S) `To` (S `To` LS))  = createEvalandArg "String -> String"
  doArgs ((S `To` (S `To` S)) `To` _)   = createEval "String -> String -> String"
  doArgs ((S `To` B)  `To` (LS `To` LS)) = createEval "String -> Bool"
  doArgs ((S `To` S)  `To` (LS `To` LS)) = createEval "String -> String"
  doArgs ((S `To` S) `To` (LS `To` S))  = createEval "String -> String"
  doArgs ((S `To` S) `To` (S `To` S))   = createEval "String -> String"
  doArgs (LS `To` (LS `To` LS))         = readFileArgandFileOrStdin
  doArgs (S  `To` (LS `To` _))          = readArgAndFileOrStdin
  doArgs (I  `To` (LS `To` _))          = readNumberAndFileOrStdin
  doArgs (S  `To` LS)                   = readArgumentOrConcatStdin
  doArgs (S  `To` S)                    = readFromFileOrStdin
  doArgs (LS `To` _)                    = readFromFileOrStdin
  
  doRawArgs :: Type -> String -> String -> String
  doRawArgs ((S `To` S) `To` (LS `To` LS)) = createRawEval "String -> String"
  doRawArgs ((S `To` B) `To` (LS `To` LS)) = createRawEval "String -> Bool"
  doRawArgs (LS `To` (LS `To` LS))         = readFileArgandRawFileOrStdin
  doRawArgs (S  `To` (LS `To` _))          = readArgAndRawFileOrStdin
  doRawArgs (I  `To` (LS `To` _))          = readNumberAndRawFileOrStdin
  doRawArgs (S  `To` S)                    = readFromRawFileOrStdinNoConcat
  doRawArgs (S  `To` LS)                   = readRawArgumentOrConcatStdin
  doRawArgs (LS `To` _)                    = readFromRawFileOrStdin
  
  ------------------------------------------------------------------------
  -- The different ways to gather arguments
  --
  
  readFromFileOrStdin :: String
  readFromFileOrStdin = unlines
    [ " input <- if null fs"
    , "          then getContents"
    , "          else liftM concat $ mapM readFile fs"
    ]
  
  readArgumentOrConcatStdin :: [Char]
  readArgumentOrConcatStdin = unlines
      [ " input <- case fs of"
      , "             [] -> liftM (concat.lines) getLine" -- maybe?
      , "             _  -> return $ concat . intersperse \" \" $ fs"
      ]
  
  readArgAndFileOrStdin :: String
  readArgAndFileOrStdin = unlines
    [" (a,input)  <- case fs of"
    ,"       []     -> error \"missing argument\""
    ,"       (x:xs) -> do inp <- if null xs"
    ,"                           then getContents"
    ,"                           else liftM concat $ mapM readFile xs"
    ,"                    return (x,inp)"
    ] 
  
  readFileArgandFileOrStdin :: String
  readFileArgandFileOrStdin = unlines
    [" (a,input)  <- case fs of"
    ,"       []     -> error \"missing argument\""
    ,"       (x:xs) -> do x'  <- liftM lines (readFile x)"
    ,"                    inp <- if null xs"
    ,"                           then getContents"
    ,"                           else liftM concat $ mapM readFile xs"
    ,"                    return (x',inp)"
    ] 
  
  readNumberAndFileOrStdin :: String
  readNumberAndFileOrStdin = unlines
    [ " let (a,fs') = case fs of"
    , "         []     -> error \"missing integer argument\""
    , "         (m:ms) -> case reads m of"
    , "                     [(m',[])] -> (m',ms)"
    , "                     s  -> error $ \"not an Integer argument:\" ++ show s"
    , " input <- if null fs'"
    , "            then getContents"
    , "            else liftM concat $ mapM readFile fs'" ]
  
  --
  -- eval a code fragment to a haskell value.
  -- there are two ways:
  --      1) run the entire src in ghci
  --      2) use hs-plugins System.Eval.
  -- we take the latter, though there's the extra cost of compilation time
  -- (though the performance will be that of compiled code aftewards)
  --
  createEval :: [Char] -> [Char]
  createEval ty = context ++ eflag ++ evalCode ty ++ unlines
    [ " input <- if null fs'"
    , "          then getContents"
    , "          else liftM concat $ mapM readFile fs'" ]
  
  createEvalandArg :: [Char] -> [Char]
  createEvalandArg ty = context ++ eflag ++ evalCode ty ++ unlines
    [" let input = concat . intersperse \" \" $ fs'"]
  
  eflag :: String
  eflag = unlines
    [ " let (e,fs') = case fs of"
    , "        (e:es) -> (e,es)"
    , "        _      -> error \"missing expression argument\"" ]
  
  -- unsafeEval is ok, as we provide the type. it's also 7% faster
  evalCode :: [Char] -> String
  evalCode ty = unlines
    [ " interpreterResult <- runInterpreter $ do"
    , "     setImportsQ context"
    , "     interpret e (as :: "++ty++")"
    , " a <- case interpreterResult of"
    , "         Left e -> error $ \"compile error: \" ++ show e"
    , "         Right result -> return result" ]
  
  context :: String
  context = unlines
    [ " let context = zip (prehier ++ datas ++ controls ++ misc) (repeat Nothing) ++ qualifieds"
    , "     prehier = [\"Char\", \"List\", \"Maybe\", \"Numeric\", \"Random\" ]"
    , "     qualifieds = [(\"Data.Map\", Just \"M\"), (\"Data.Set\", Just \"S\")]"
    , "     datas   = map (\"Data.\" ++) ["
    , "                   \"Bits\", \"Bool\", \"Char\", \"Either\","
    , "                   \"Graph\", \"Int\", \"Ix\", \"List\","
    , "                   \"Maybe\", \"Ratio\", \"Tree\", \"Tuple\", \"Typeable\", \"Word\""
    , "                 ]"
    , "     controls = map (\"Control.\" ++) "
    , "        [\"Monad\", \"Monad.Reader\", \"Monad.Fix\", \"Arrow\"]" 
    , "     misc = [\"Text.Regex\", \"H4SH.List\"]"
    ]
  
  -- ---------------------------------------------------------------------
  
  createRawEval :: String -> String -> String -> String
  createRawEval ty f a = context ++ eflag ++ evalCode ty ++ unlines
    [ " input <- case fs' of"
    , "   [] -> P.getContents"
    , "   _  -> mapM "++f++" fs' >>= \\ps -> return $ P.concat ps"
    , " " ++ a
    ]
  
  -- ---------------------------------------------------------------------
  --
  -- ways to get a files using an efficient packed string mechanism
  --
  
  readFromRawFileOrStdin f a = unlines
    [ " input <- case fs of"
    , "   [] -> P.getContents"
    , "   _  -> mapM "++f++" fs >>= \\ps -> return $ P.concat ps"
    , " " ++ a
    ]
  
  -- special case to make `i' really fast
  readFromRawFileOrStdinNoConcat f a = unlines
    [ " case fs of"
    , "   [] -> P.getContents >>= P.putStr"
    , "   _  -> mapM_ (\\f -> "++f++" f >>= P.putStr) fs"
    ]
  
  readNumberAndRawFileOrStdin f a = unlines
    [ " let (a,fs') = case fs of"
    , "         []     -> error \"missing integer argument\""
    , "         (m:ms) -> case reads m of"
    , "                     [(m',[])] -> (m',ms)"
    , "                     s  -> error $ \"not an Integer argument:\" ++ show s"
    , " input <- case fs' of"
    , "   [] -> P.getContents"
    , "   _  -> mapM "++f++" fs' >>= \\ps -> return $ P.concat ps"
    , " " ++ a
    ]
  
  readArgAndRawFileOrStdin f a = unlines
    [" (a,input)  <- case fs of"
    ,"       []     -> error \"missing argument\""
    ,"       (x:xs) -> do inp <- if null xs"
    ,"                           then P.getContents"
    ,"                           else mapM "++f++" xs >>= \\ps -> return $ P.concat ps"
    ,"                    return (P.pack x,inp)"
    , " " ++ a
    ] 
  
  readFileArgandRawFileOrStdin f a = unlines
    [" (a,input)  <- case fs of"
    ,"       []     -> error \"missing argument\""
    ,"       (x:xs) -> do x'  <- liftM P.lines ("++f++" x)"
    ,"                    inp <- if null xs"
    ,"                           then P.getContents"
    ,"                           else mapM "++f++" xs >>= \\ps -> return $ P.concat ps"
    ,"                    return (x',inp)"
    ," " ++ a
    ] 
  
  readRawArgumentOrConcatStdin :: String -> [Char] -> String
  readRawArgumentOrConcatStdin _ a = unlines
      [ " input <- case fs of"
      , "             [] -> liftM (P.pack.concat.lines) getContents" -- ?
      , "             _  -> return $ P.pack . concat . intersperse \" \" $ fs"
      , " " ++ a
      ]
  
  -- ---------------------------------------------------------------------
  --
  -- generate the getopt code
  --
  parseArgs :: Command -> String
  parseArgs (Command _ f  ty  _ _) = unlines $
    [ "data Flag = Version | Help deriving Eq"
    , ""
    , "opts :: [OptDescr Flag]"
    , "opts = "
    , "  [ Option ['V'] [\"version\"]      (NoArg Version) \"version string\""
    , "  , Option ['h'] [\"help\"]         (NoArg Help)    \"help\""
    , "  ]"
    , ""
    , "parseArgs argv = case (getOpt Permute opts argv) of"
    , " (flags,fs,[]) -> case () of { _"
    , "     | Version `elem` flags -> putStrLn version >> exitWith ExitSuccess"
    , "     | Help    `elem` flags -> putStrLn usage >> putStr help >> exitWith ExitSuccess"
    , "     | otherwise            -> return (flags,fs)"
    , " }"
    , " (_,_,err) -> error $ concat err ++ usage"
    , " where usage = usageInfo (\"Usage: \\\""++f++"\\\" [OPTION...] [file..]\") opts" ]
  
  