bird-0.0.17: bin/bird.hs

module Main where
import Directory
import System.Process
import System.Environment (getArgs)
import List
import Data.List
import Data.List.Utils (join)

main = do
  args <- getArgs
  runArg args

runArg arguments =
  case arguments of
    ["help"] -> printHelp
    ["--help"] -> printHelp
    ["nest"] -> do
      appModuleNamePath <- getCurrentDirectory
      appModuleName <- return $ head . reverse $ split '/' appModuleNamePath
      app <- readFile $ appModuleName ++ ".bird.hs"
      let reformattedApp = reformatApp (lines app)
      writeFile (appModuleName ++ ".hs") ((appModulePrelude appModuleName)++ "\n" ++ reformattedApp ++ "\n")
      system "ghc --make -O2 Main.hs"
      files <- getDirectoryContents appModuleNamePath
      system "rm *.o *.hi "
      renameFile "Main" (appModuleName ++ "App")
      return ()
    ["fly"] -> do
      appModuleNamePath <- getCurrentDirectory
      appModuleName <- return $ head . reverse $ split '/' appModuleNamePath
      system $ "./" ++ appModuleName ++ "App"
      return ()
    ["hatch", appName] -> createBirdApp appName
    (action:_) -> do
      putStrLn $ "Unrecognized action: " ++ (show action) ++ "\n"
      printHelp
    [] -> printHelp

reformatApp app = join "\n" $ strippedApp ++ getFunction ++ postFunction ++ putFunction ++ deleteFunction
  where
    getFunction = extractFunction "get" app
    postFunction = extractFunction "post" app
    putFunction = extractFunction "put" app
    deleteFunction = extractFunction "delete" app
    strippedApp = app \\ (concat [getFunction, postFunction, putFunction, deleteFunction])

printHelp = do
  putStrLn $ "Usage: bird action [options]\n\n" ++
             "  Actions:\n" ++
             "    hatch -> create a new Bird app, takes the name as an argument, for example `bird hatch StarWars`\n" ++
             "    nest  -> compile your Bird app\n" ++
             "    fly   -> expose your Bird app to the world (on port 3000)\n"

appModulePrelude appModuleName =
  "--This file is generated by bird. It will be overwritten the next time you run 'bird nest'. Edit at your own peril.\n" ++
  "module " ++ appModuleName ++ " where\n" ++
  "import Bird\n" ++
  "import Prelude hiding( log )\n\n"

createBirdApp a = do
  createDirectory a
  createDirectory (a ++ "/" ++ a ++ "/")
  writeFile (a ++ "/" ++ a ++ ".bird.hs") (routeFile a)
  writeFile (a ++ "/" ++ "Main.hs") (mainFile a)
  writeFile (a ++ "/" ++ a ++ "/Config.hs") (configFile a)
  putStrLn $ "A fresh Bird app has been created in " ++ a ++ "."

routeFile a = "get [] = body \"Hello, Bird!\""

configFile a = 
  "module " ++ a ++ ".Config where\n\n" ++
  "import Bird\n\n" ++ 
  "config :: BirdConfig\n" ++
  "config = def\n"

mainFile a =
  "import Hack\n" ++
  "import qualified Hack as Hack\n" ++
  "import Hack.Handler.Happstack\n" ++
  "import Bird\n" ++
  "import qualified Bird as Bird\n" ++
  "import Bird.Translator.Hack\n" ++
  "import qualified Control.Monad.State as S\n" ++
  "import qualified Control.Monad.Reader as R\n" ++
  "import " ++ a ++ "\n" ++
  "import " ++ a ++ ".Config\n\n" ++

  "app :: Application\n" ++
  "app = \\e -> route e\n" ++ "\n" ++

  "route :: Env -> IO Response\n" ++
  "route e = response\n" ++
  "  where \n" ++
  "    req = toBirdRequest e\n" ++
  "    response = do \n" ++
  "      reply <- (birdLogger config) req matchRequest\n" ++
  "      return $ fromBirdReply reply\n\n" ++

  "matchRequest r = \n" ++
  "  case verb r of \n" ++
  "    Bird.GET -> get $ path r\n" ++
  "    Bird.POST -> post $ path r\n" ++
  "    Bird.PUT -> put $ path r\n" ++
  "    Bird.DELETE -> delete $ path r\n\n" ++

  "main = do\n" ++
  "  putStrLn \"A bird was just spotted in flight at http://localhost:3000\"\n" ++
  "  run app\n"

extractFunction :: String -> [String] -> [String]
extractFunction f program = (concat (findAll f program)) ++ [(f ++ " _ = status 404")]

findAll _ [] = []
findAll function program =  
  case (dropWhile (not . ((function ++ " ") `isPrefixOf`)) program) of 
    [] -> []
    (l:ls) -> 
      f : findAll function remainingProgram
        where
          (functionBody, remainingProgram) = break (not . (" " `isPrefixOf`)) ls
          f = [l] ++ functionBody

split :: Char -> String -> [String]
split d s
  | findSep == [] = []
  | otherwise     = t : split d s''
    where
      (t, s'') = break (== d) findSep
      findSep = dropWhile (== d) s