module IHP.IDE.CodeGen.Controller where import IHP.ControllerPrelude hiding (appPort) import IHP.IDE.ToolServer.Types import IHP.IDE.CodeGen.View.Generators import IHP.IDE.CodeGen.View.NewController import IHP.IDE.CodeGen.View.NewScript import IHP.IDE.CodeGen.View.NewView import IHP.IDE.CodeGen.View.NewMail import IHP.IDE.CodeGen.View.NewAction import IHP.IDE.CodeGen.View.NewApplication import IHP.IDE.CodeGen.View.NewJob import IHP.IDE.CodeGen.Types import IHP.IDE.CodeGen.ControllerGenerator as ControllerGenerator import IHP.IDE.CodeGen.ScriptGenerator as ScriptGenerator import IHP.IDE.CodeGen.ViewGenerator as ViewGenerator import IHP.IDE.CodeGen.MailGenerator as MailGenerator import IHP.IDE.CodeGen.ActionGenerator as ActionGenerator import IHP.IDE.CodeGen.ApplicationGenerator as ApplicationGenerator import IHP.IDE.CodeGen.JobGenerator as JobGenerator import IHP.IDE.ToolServer.Helper.Controller import qualified System.Process as Process import qualified System.Directory as Directory import qualified Data.Text as Text import qualified Data.Text.IO as Text import qualified Text.Inflections as Inflector import System.Directory instance Controller CodeGenController where action GeneratorsAction = do render GeneratorsView action NewControllerAction = do let controllerName = paramOrDefault "" "name" let applicationName = paramOrDefault "Web" "applicationName" let pagination = paramOrDefault False "pagination" controllerAlreadyExists <- doesControllerExist controllerName applicationName applications <- findApplications when controllerAlreadyExists do setErrorMessage "Controller with this name does already exist." redirectTo NewControllerAction plan <- ControllerGenerator.buildPlan controllerName applicationName pagination render NewControllerView { .. } where doesControllerExist controllerName applicationName = doesFileExist $ cs applicationName <> "/Controller/" <> cs controllerName <> ".hs" action CreateControllerAction = do let controllerName = param "name" let applicationName = param "applicationName" let pagination = paramOrDefault False "pagination" (Right plan) <- ControllerGenerator.buildPlan controllerName applicationName pagination executePlan plan setSuccessMessage "Controller generated" redirectTo GeneratorsAction action NewScriptAction = do let scriptName = paramOrDefault "" "name" scriptAlreadyExists <- doesFileExist $ "Application/Script/" <> cs scriptName <> ".hs" when scriptAlreadyExists do setErrorMessage "Script with this name already exists." redirectTo NewScriptAction let plan = ScriptGenerator.buildPlan scriptName render NewScriptView { .. } action CreateScriptAction = do let scriptName = paramOrDefault "" "name" let (Right plan) = ScriptGenerator.buildPlan scriptName executePlan plan setSuccessMessage "Script generated" redirectTo GeneratorsAction action NewViewAction = do let viewName = paramOrDefault "" "name" let applicationName = paramOrDefault "Web" "applicationName" let controllerName = paramOrDefault "" "controllerName" viewAlreadyExists <- doesFileExist $ (cs applicationName) <> "/View/" <> (cs controllerName) <> "/" <> (cs viewName) <>".hs" when viewAlreadyExists do setErrorMessage "View with this name already exists." redirectTo NewViewAction controllers <- findControllers applicationName applications <- findApplications plan <- ViewGenerator.buildPlan viewName applicationName controllerName render NewViewView { .. } action CreateViewAction = do let viewName = paramOrDefault "" "name" let applicationName = paramOrDefault "Web" "applicationName" let controllerName = paramOrDefault "" "controllerName" (Right plan) <- ViewGenerator.buildPlan viewName applicationName controllerName executePlan plan setSuccessMessage "View generated" redirectTo GeneratorsAction action NewMailAction = do let mailName = paramOrDefault "" "name" let applicationName = paramOrDefault "Web" "applicationName" let controllerName = paramOrDefault "" "controllerName" mailAlreadyExists <- doesFileExist $ (cs applicationName) <> "/Mail/" <> (cs controllerName) <> "/" <> (cs mailName) <>".hs" when mailAlreadyExists do setErrorMessage "Mail with this name already exists." redirectTo NewMailAction controllers <- findControllers applicationName applications <- findApplications plan <- MailGenerator.buildPlan mailName applicationName controllerName render NewMailView { .. } action CreateMailAction = do let mailName = paramOrDefault "" "name" let applicationName = paramOrDefault "Web" "applicationName" let controllerName = paramOrDefault "" "controllerName" (Right plan) <- MailGenerator.buildPlan mailName applicationName controllerName executePlan plan setSuccessMessage "Mail generated" redirectTo GeneratorsAction action NewActionAction = do let actionName = paramOrDefault "" "name" let applicationName = paramOrDefault "Web" "applicationName" let controllerName = paramOrDefault "" "controllerName" let doGenerateView = paramOrDefault False "doGenerateView" controllers <- findWebControllers applications <- findApplications plan <- ActionGenerator.buildPlan actionName applicationName controllerName doGenerateView render NewActionView { .. } action CreateActionAction = do let actionName = paramOrDefault "" "name" let applicationName = paramOrDefault "Web" "applicationName" let controllerName = paramOrDefault "" "controllerName" let doGenerateView = paramOrDefault False "doGenerateView" (Right plan) <- ActionGenerator.buildPlan actionName applicationName controllerName doGenerateView executePlan plan setSuccessMessage $ "Action" ++ (if doGenerateView then " and View " else "") ++ " generated" redirectTo GeneratorsAction action NewApplicationAction = do let applicationName = paramOrDefault "" "name" plan <- ApplicationGenerator.buildPlan applicationName render NewApplicationView { .. } action CreateApplicationAction = do let applicationName = paramOrDefault "" "name" (Right plan) <- ApplicationGenerator.buildPlan applicationName executePlan plan setSuccessMessage "Application generated" redirectTo GeneratorsAction action NewJobAction = do let jobName = paramOrDefault "" "name" let applicationName = paramOrDefault "Web" "applicationName" controllers <- findControllers applicationName applications <- findApplications plan <- JobGenerator.buildPlan jobName applicationName render NewJobView { .. } action CreateJobAction = do let jobName = paramOrDefault "" "name" let applicationName = paramOrDefault "Web" "applicationName" (Right plan) <- JobGenerator.buildPlan jobName applicationName executePlan plan setSuccessMessage "Job generated" redirectTo GeneratorsAction action OpenControllerAction = do let name = param "name" case name |> Inflector.toCamelCased True of Left error -> renderPlain "Failed to transform name to camel case" Right indexActionName-> do appPort <- theAppPort redirectToUrl ("http://localhost:" <> tshow appPort <> "/" <> indexActionName) executePlan :: [GeneratorAction] -> IO () executePlan actions = forEach actions evalAction where evalAction CreateFile { filePath, fileContent } = do Text.writeFile (cs filePath) (cs fileContent) putStrLn ("+ " <> filePath) evalAction AppendToFile { filePath, fileContent } = do Text.appendFile (cs filePath) fileContent putStrLn ("* " <> filePath) evalAction AppendToMarker { marker, filePath, fileContent } = do content <- Text.readFile (cs filePath) let newContent = Text.replace marker (marker <> "\n" <> cs fileContent) (cs content) Text.writeFile (cs filePath) (cs newContent) putStrLn ("* " <> filePath <> " (import)") evalAction AddImport { filePath, fileContent } = do addImport filePath fileContent putStrLn ("* " <> filePath <> " (import)") evalAction AddAction { filePath, fileContent } = do addAction filePath [fileContent] putStrLn ("* " <> filePath <> " (AddAction)") evalAction AddMountToFrontController { filePath, applicationName } = do addMountControllerStatement filePath applicationName putStrLn ("* " <> filePath <> " (AddMountToFrontController)") evalAction AddToDataConstructor { dataConstructor, filePath, fileContent } = do content <- Text.readFile (cs filePath) case addToDataConstructor content dataConstructor fileContent of Just newContent -> do Text.writeFile (cs filePath) (cs newContent) putStrLn ("* " <> filePath <> " (AddToDataConstructor)") Nothing -> putStrLn ("Could not automatically add " <> tshow content <> " to " <> filePath) evalAction EnsureDirectory { directory } = do Directory.createDirectoryIfMissing True (cs directory) evalAction RunShellCommand { shellCommand } = do _ <- Process.system (cs shellCommand) putStrLn ("* " <> shellCommand) undoPlan :: [GeneratorAction] -> IO() undoPlan actions = forEach actions evalAction where evalAction CreateFile { filePath, fileContent } = do (Directory.removeFile (cs filePath)) `catch` handleError putStrLn ("- " <> filePath) evalAction AppendToFile { filePath, fileContent } = do deleteTextFromFile (cs filePath) fileContent `catch` handleError putStrLn ("* " <> filePath) evalAction AppendToMarker { marker, filePath, fileContent } = do (deleteTextFromFile (cs filePath) (fileContent <> "\n")) `catch` handleError putStrLn ("* " <> filePath <> " (import)") evalAction AddImport { filePath, fileContent } = do (deleteTextFromFile (cs filePath) (fileContent <> "\n")) `catch` handleError putStrLn ("* " <> filePath <> " (import)") evalAction AddAction { filePath, fileContent } = do (deleteTextFromFile (cs filePath) (fileContent <> "\n")) `catch` handleError putStrLn ("* " <> filePath <> " (RemoveAction)") evalAction AddToDataConstructor { dataConstructor, filePath, fileContent } = do (deleteTextFromFile (cs filePath) (fileContent <> "\n")) `catch` handleError putStrLn ("* " <> filePath <> " (RemoveFromDataConstructor)") evalAction EnsureDirectory { directory } = do (Directory.removeDirectory (cs directory)) `catch` handleError evalAction RunShellCommand { shellCommand } = pure () handleError :: SomeException -> IO () handleError ex = putStrLn (tshow ex) deleteTextFromFile :: Text -> Text -> IO () deleteTextFromFile filePath lineContent = do fileContent <- Text.readFile (cs filePath) let replacedContent = Text.replace lineContent "" fileContent Text.writeFile (cs filePath) replacedContent addImport :: Text -> Text -> IO () addImport file importStatement = do content :: Text <- Text.readFile (cs file) case addImport' content importStatement of Just newContent -> Text.writeFile (cs file) (cs newContent) Nothing -> pure () pure () addImport' :: Text -> Text -> Maybe Text addImport' content importStatement = do if importStatement `isInfixOf` content then Nothing else appendLineAfter content ("import" `isPrefixOf`) [importStatement] addAction :: Text -> [Text] -> IO () addAction filePath fileContent = do content <- Text.readFile (cs filePath) case addAction' content fileContent of Just newContent -> Text.writeFile (cs filePath) (cs newContent) Nothing -> putStrLn ("Could not automatically add " <> tshow content <> " to " <> filePath) pure () addAction' :: Text -> [Text] -> Maybe Text addAction' fileContent = appendLineAfter fileContent ("instance Controller" `isPrefixOf`) addMountControllerStatement :: Text -> Text -> IO () addMountControllerStatement file applicationName = do content :: Text <- Text.readFile (cs file) case addMountControllerStatement' applicationName content of Just newContent -> Text.writeFile (cs file) (cs newContent) Nothing -> putStrLn ("Could not automatically add " <> tshow applicationName <> " to " <> file) pure () addMountControllerStatement' :: Text -> Text -> Maybe Text addMountControllerStatement' applicationName file = let withMaybeMountedFrontController = appendLineAfter file ("mountFrontController" `isInfixOf`) [" , mountFrontController " <> applicationName <> "Application"] in case withMaybeMountedFrontController of Just result -> Just result Nothing -> Just (Text.replace needle replacement file) where needle = " controllers = []" replacement = " controllers = [\n mountFrontController " <> applicationName <> "Application" <> "\n ]" -- | Gets content of a Types.hs, a existent data constructor and a type which should be added to it -- and returns fileContent with the type in it. addToDataConstructor :: Text -> Text -> Text -> Maybe Text addToDataConstructor fileContent dataConstructor content = do lineOfDataConstructor <- lines fileContent |> zip [1..] |> filter (\(n, line) -> dataConstructor `isInfixOf` line) |> lastMay |> fmap fst lineOfDerivingStatement <- ((drop lineOfDataConstructor $ lines fileContent) :: [Text]) |> zip [lineOfDataConstructor..] |> filter (\(n, line) -> "deriving" `isInfixOf` line) |> headMay |> fmap fst Just $ unlines $ ((take lineOfDerivingStatement $ lines fileContent) <> [content] <> (drop lineOfDerivingStatement $ lines fileContent)) appendLineAfter :: Text -> (Text -> Bool) -> [Text] -> Maybe Text appendLineAfter file isRelevantLine newLines = let content :: [Text] = lines file lastImportLine = content |> zip [1..] |> filter (\(n, line) -> isRelevantLine line) |> lastMay |> fmap fst in fmap (\lastImportLine -> unlines $ (take lastImportLine content) <> newLines <> (drop lastImportLine content)) lastImportLine