Add cpm: Clean Project Management

cpm/Cpm.icl

+module Cpm
+
+import CommandLine
+import Environment
+import Error
+import File
+import FilePath
+import Func
+import IdeState
+import List
+import logfile
+import ParserCombinators
+import Platform
+import PmDriver
+import PmEnvironment
+import PmProject
+import set_return_code
+import StdEnv
+import Text
+import UtilIO
+import UtilStrictLists
+
+:: CloptAction
+  =  Project FilePath ProjectAction
+  |  Module String ModuleAction
+  |  Help
+
+:: ProjectAction
+  =  CreateProject
+  |  ShowProject
+  |  BuildProject Bool FilePath
+  |  ProjectPath PathAction
+  |  ProjectHelp
+
+:: PathAction
+  =  AddPathAction String
+  |  RemovePathAction String
+
+:: ModuleAction
+  =  CreateModule
+  |  ModuleHelp
+
+pNotSpace :: CParser Char [Char] a
+pNotSpace = sp (<+> (satisfy (not o isWhite)))
+
+pClopt :: CParser Char CloptAction a
+pClopt = pProject <|> pModule <!> yield Help
+
+spstrtok :: (String -> CParser Char [Char] a)
+spstrtok = sptoken o fromString
+
+pProject :: CParser Char CloptAction a
+pProject = spstrtok "project" &> pNotSpace <&> \pn -> pProjectAction <@ Project (toString pn)
+  where  pProjectAction  =  spstrtok "create"                                 <@ const CreateProject
+                       <|>  spstrtok "show"                                   <@ const ShowProject
+                       <|>  spstrtok "build"   &>  pForce       <&> \ f-> pIDEEnvs  <@ BuildProject f
+                       <|>  spstrtok "path"    &>  pPathAction                <@ ProjectPath
+                       <!>  yield ProjectHelp
+         pPathAction     =  spstrtok "add"     &>  pNotSpace    <@ AddPathAction o toString
+                       <|>  spstrtok "remove"  &>  pNotSpace    <@ RemovePathAction o toString
+
+pForce :: CParser Char Bool a
+pForce = spstrtok "--force" <@ const True <|> yield False
+
+pIDEEnvs :: CParser Char String a
+pIDEEnvs = spstrtok "--envs" &> (<?> (spsymbol '=')) &> pNotSpace <@ toString <!> yield EnvsFileName
+
+pModule :: CParser Char CloptAction a
+pModule = spstrtok "module" &> pNotSpace <&> \mn -> pModuleAction <@ Module (toString mn)
+  where  pModuleAction  =  spstrtok "create" <@ const CreateModule
+                      <!>  yield ModuleHelp
+
+Start :: *World -> *World
+Start world
+  # (cmd, world)  = getCommandLine world
+    cl            = concat (intersperse " " (tl [fromString arg \\ arg <- cmd]))
+    cpm           = startParse (fromString cl)
+    (pwd, world)  = accFiles GetFullApplicationPath world
+    (ch, world)   = case getEnvironmentVariable "CLEAN_HOME" world of
+                      (Just ch, world)  -> (ch, world)
+                      (_, world)        -> (pwd, world)
+  = doCloptAction world ch pwd cpm
+
+startParse :: [.Char] -> CloptAction
+startParse args =  case filter (\(xs, _) -> xs == []) (begin pClopt args) of
+                     [(_, as):_]  -> as
+                     _            -> Help
+
+doCloptAction :: *World String String .CloptAction -> .World
+doCloptAction world cleanhome  pwd  (Project pn pa)  = doProjectAction world cleanhome pwd pn pa
+doCloptAction world cleanhome  pwd  (Module mn ma)   = doModuleAction world cleanhome mn ma
+doCloptAction world _   _    _                =
+  help  [  "CPM: Clean Project Management"
+        ,  ""
+        ,  "Usage: cpm <action>"
+        ,  "Where <action> is one of the following:"
+        ,  "  project  : project actions"
+        ,  "  module   : module action"
+        ,  ""
+        ,  "Execute `cpm <action> help` to get help for specific actions."] world
+
+doProjectAction :: *World .String .String .String .ProjectAction -> .World
+doProjectAction world cleanhome pwd  pn  CreateProject
+  # basefilename      = dropExtension pn
+  # mainmodule        = addExtension basefilename "icl"
+  # projectfile       = addExtension basefilename "prj"
+  //Check if main module exists
+  # (exists,world)    = fileExists mainmodule world
+  | not exists        = error ("Main module " +++ mainmodule +++ " does not exist.") world
+  //Create project file using the Clean IDE libraries 
+  # edit_options      = {eo={newlines=NewlineConventionUnix},pos_size=NoWindowPosAndSize}
+  # compiler_options  = DefaultCompilerOptions;
+  # project           = PR_NewProject mainmodule edit_options compiler_options DefCodeGenOptions
+                          DefApplicationOptions [!!] DefaultLinkOptions
+  # project           = PR_SetRoot mainmodule edit_options compiler_options project
+  # (err,world)       = accFiles (SaveProjectFile projectfile project cleanhome) world
+  | err               = error ("Could not create project file " +++ projectfile) world
+  = world
+
+doProjectAction world cleanhome pwd  pn  ShowProject
+  # projectfile      = addExtension (dropExtension pn) "prj"
+  //Open the projectfile
+  # (mbProj ,world)  = openProject cleanhome projectfile world
+  = case mbProj of
+      Error e     -> error e world
+      Ok project  -> show  [  "Content of " +++ projectfile
+                           ,  "Target: " +++ PR_GetTarget project
+                           ,  "Executable: " +++ PR_GetExecPath project
+                           ,  "Paths:"
+                           :  [toString p \\ p <- StrictListToList (PR_GetPaths project)]
+                           ] world
+
+doProjectAction world cleanhome pwd  pn  (BuildProject force ideenvs)
+  # envsfile                   = application_path ideenvs
+  # (envs, world)              = openEnvironments cleanhome envsfile world
+  # ((proj, ok, err), world)   = accFiles (ReadProjectFile pn cleanhome) world
+  | not ok || err <> ""        = error ("BatchBuild failed while opening project: "+++.err+++."\n") world
+  # (ok, logfile, world)       = openLogfile pn world
+  | not ok                     = error ("BatchBuild failed while opening logfile.\n") world
+  # default_compiler_options   = DefaultCompilerOptions
+  # iniGeneral                 = initGeneral True default_compiler_options cleanhome pn proj envs logfile
+  # ps                         = {ls=iniGeneral,gst_world=world,gst_continue_or_stop=False}
+  # {ls, gst_world}            = pinit force ps
+  = gst_world
+
+doProjectAction world cleanhome  _  pn  (ProjectPath pa)  = doProjectPathAction world cleanhome pn pa
+doProjectAction world _     _  _   _                 =
+  help  [  "create             : create a new project"
+        ,  "show               : show project information"
+        ,  "build [--force]    : build the project. Optionally force build (default: 'false')"
+        ,  "path <add|remove>  : add or remove a path from the project"
+        ,  "help               : show this help message"] world
+
+doProjectPathAction :: *World .String .String .PathAction -> .World
+doProjectPathAction world cleanhome pn (AddPathAction path)
+   # projectfile      = addExtension (dropExtension pn) "prj"
+   //Open the projectfile
+   # (mbProj, world)  = openProject cleanhome projectfile world
+   = case mbProj of
+       Error e      = error e world
+       Ok project
+         # paths    = StrictListToList (PR_GetPaths project)
+         = help ["Paths" +++ toString (length paths)] world
+
+doProjectPathAction world cleanhome pn (RemovePathAction path)  = undef
+
+openProject :: !FilePath !FilePath !*World -> (!MaybeErrorString Project,!*World)
+openProject cleanhome projectfile world
+  # ((prj, ok, err), world) = accFiles (ReadProjectFile projectfile cleanhome) world
+  | ok  = (Ok prj, world)
+        = (Error err, world)
+
+doModuleAction :: *World .String .String .ModuleAction -> .World
+doModuleAction world cleanhome mn  CreateModule
+  # basenm              = dropExtension mn
+  # dclnm               = addExtension basenm "dcl"
+  # iclnm               = addExtension basenm "icl"
+  # (dclexists, world)  = fileExists dclnm world
+  | dclexists           = error ("Definition module '" +++ dclnm +++ "' already exists.") world
+  # (iclexists, world)  = fileExists iclnm world
+  | dclexists           = error ("Implementation module '" +++ iclnm +++ "' already exists.") world
+  = undef
+
+doModuleAction world _ _   _                  =
+  help  [  "create [application|library]  : create a new module. Optionally specify module type (default: 'library')"
+        ,  "help                          : show this help message"] world
+
+error :: {#.Char} *World -> .World
+error message world
+  # stderr      = fwrites message stderr
+  # (ok,world)  = fclose stderr world
+  # world       = set_return_code_world (-1) world
+  = world
+
+help :: ![String] !*World -> *World
+help lines world
+  # (console,world)  = stdio world
+  # console          = seqSt (\s c -> fwrites (s +++ "\n") c) lines console
+  # (_,world)        = fclose console world
+  = world
+
+show :: ![String] !*World -> *World
+show ls w = help ls w
+
+// TODO: Use the version from BatchBuild
+pinit :: .Bool *GeneralSt -> *GeneralSt
+pinit force_rebuild ps
+  = BringProjectUptoDate force_rebuild cleanup ps
+where
+  cleanup exepath bool1 bool2 ps
+    = abortLog False "" ps