Skip to content

GitLab

Commit 34910221 authored by Jurrien Stutterheim's avatar Jurrien Stutterheim
Browse files

CPM: Add target and exec project options. Add top/bottom path manipulation. Refactor.

parent b0d93db6
Hide whitespace changes
Inline Side-by-side
Showing with 92 additions and 41 deletions
cpm/Cpm.icl
View file @ 34910221
......@@ -70,6 +70,7 @@ import UtilStrictLists
:: CpmAction
= Project FilePath ProjectAction
| Module String ModuleAction
| Environment EnvironmentAction
| CpmHelp
:: ProjectAction
......@@ -77,6 +78,9 @@ import UtilStrictLists
| ShowProject
| BuildProject Bool FilePath
| ProjectPath PathAction
//| SetProjectRoot String TODO: Not yet supported by PmProject
| SetTarget String
| SetExec String
| ProjectHelp
:: PathAction
......@@ -89,6 +93,8 @@ import UtilStrictLists
:: PathDirection
= PathUp
| PathDown
| PathTop
| PathBottom
:: ModuleAction
= CreateModule ModuleType
......@@ -98,6 +104,9 @@ import UtilStrictLists
= ApplicationModule
| LibraryModule
:: EnvironmentAction
= ShowEnvironment
/**
* Parsers
*/
......@@ -121,16 +130,25 @@ pCpm = pProject <|> pModule <!> (yield CpmHelp)
spstrtok :: (String -> CParser Char [Char] a)
spstrtok = sptoken o fromString
/**
* Parser for boolean values
*/ // TODO: REmove?
//pBool :: CParser Char Bool a
//pBool = pConstCtr [("true", True), ("True", True), ("false", False), ("False", False)]
/**
* Parser for the project commands
*/
pProject :: CParser Char CpmAction a
pProject = spstrtok "project" &> (pProjectWithName <!> yield (Project "" ProjectHelp))
where pProjectWithName = pNotSpace <&> \pn -> pProjectAction <@ Project (toString pn)
pProjectAction = (spstrtok "create" <@ const CreateProject)
<|> (spstrtok "show" <@ const ShowProject)
<|> (spstrtok "build" &> pForce <&> \ f -> pIDEEnvs <@ BuildProject f)
<|> (spstrtok "path" &> pPathAction)
pProjectAction = (spstrtok "create" <@ const CreateProject)
<|> (spstrtok "show" <@ const ShowProject)
<|> (spstrtok "build" &> pForce <&> \f -> pIDEEnvs <@ BuildProject f)
<|> (spstrtok "path" &> pPathAction)
//<|> (spstrtok "projectroot" &> pNotSpace <@ SetProjectRoot o toString)
<|> (spstrtok "target" &> identifier <@ SetTarget o toString)
<|> (spstrtok "exec" &> identifier <@ SetExec o toString)
<!> (pHelp ProjectHelp)
/**
......@@ -138,12 +156,19 @@ pProject = spstrtok "project" &> (pProjectWithName <!> yield (Project "" Project
*/
pPathAction :: CParser Char ProjectAction a
pPathAction = pPathAction <@ ProjectPath
where pPathAction = (spstrtok "add" &> pNotSpace <@ AddPathAction o toString)
<|> (spstrtok "remove" &> sp nat <@ RemovePathAction)
<|> (spstrtok "list" <@ const ListPathsAction)
where pPathAction = (spstrtok "add" &> pNotSpace <@ AddPathAction o toString)
<|> (spstrtok "remove" &> sp nat <@ RemovePathAction)
<|> (spstrtok "list" <@ const ListPathsAction)
<|> (spstrtok "move" &> pPathDirection)
<!> (pHelp PathHelp)
pPathDirection = sp nat <&> \i -> ((spstrtok "up" <@ const PathUp) <|> (spstrtok "down" <@ const PathDown)) <@ MovePathAction i
pPathDirection = sp nat <&> \i -> pConstCtr dirOpts <@ MovePathAction i
dirOpts = [("up", PathUp), ("down", PathDown), ("top", PathTop), ("bottom", PathBottom)]
/**
* Parser for constant mappings between text and constructors
*/
pConstCtr :: [(String, c)] -> CParser Char c a
pConstCtr xs = choice (map (\(s, d) -> (spstrtok s <@ const d)) xs)
/**
* Parser to toggle the --force flag
......@@ -241,16 +266,15 @@ doProjectAction cleanhome pwd pn CreateProject world
doProjectAction cleanhome pwd pn ShowProject world
# projectfile = addExtension (dropExtension pn) "prj"
//Open the projectfile
# (mbProj, world) = openProject cleanhome projectfile world
= case mbProj of
Error e -> error e world
Ok project -> showLines
[ "Content of " +++ projectfile
, "Target: " +++ PR_GetTarget project
, "Executable: " +++ PR_GetExecPath project
, "Paths:"
: [toString p \\ p <- StrictListToList (PR_GetPaths project)]
] world
# (project, world) = openProject cleanhome projectfile world
= showLines [ "Content of " +++ projectfile +++ ":"
, "ProjectRoot..: " +++ PR_GetRelativeRootDir project
, "Built........: " +++ toString (PR_Built project)
, "Target.......: " +++ PR_GetTarget project
, "Executable...: " +++ PR_GetExecPath project
, "Paths........:"
: showPaths project
] world
doProjectAction cleanhome pwd pn (BuildProject force ideenvs) world
# (envs, world) = openEnvironments cleanhome envsfile world
......@@ -265,12 +289,16 @@ doProjectAction cleanhome pwd pn (BuildProject force ideenvs) world
proj_path = GetLongPathName pn
doProjectAction cleanhome _ pn (ProjectPath pa) world
# projectfile = addExtension (dropExtension pn) "prj"
//Open the projectfile
# (mbProj, world) = openProject cleanhome projectfile world
= case mbProj of
Error e -> error e world
Ok project -> doProjectPathAction cleanhome projectfile project pa world
# projectfile = addExtension (dropExtension pn) "prj"
//Open the projectfile
# (project, world) = openProject cleanhome projectfile world
= doProjectPathAction cleanhome projectfile project pa world
doProjectAction cleanhome pwd pn (SetTarget target) world =
withProject cleanhome pn (PR_SetTarget target) world
doProjectAction cleanhome pwd pn (SetExec exec) world =
withProject cleanhome pn (PR_SetExecPath exec) world
doProjectAction _ _ _ _ world =
help "cpm project <projectname> <action>"
......@@ -279,7 +307,19 @@ doProjectAction _ _ _ _ world =
, " show : show project information"
, " build [--force] [--envs=filename] : build the project. Optionally force build (default: 'false')"
, " Optionally specify the environments file (default: 'IDEEnvs')"
, " path : manage project paths"] world
, " path : manage project paths"
, " target <env> : set target environment to <env>"
, " exec <execname> : set executable name to <execname>"
] world
/**
* Modify a project
*/
withProject :: String String .(Project -> Project) *World -> .World
withProject cleanhome pn f world
# projectfile = addExtension (dropExtension pn) "prj"
# (project, world) = openProject cleanhome projectfile world
= saveProject cleanhome (f project) projectfile world
/**
* Execute path-related project actions
......@@ -291,9 +331,7 @@ doProjectPathAction cleanhome pn project (AddPathAction path) world =
doProjectPathAction cleanhome pn project (RemovePathAction i) world =
doModPaths cleanhome pn project (rmStrictListIdx i) world
doProjectPathAction _ _ project ListPathsAction world = showLines ["Paths for project:" : paths] world
where paths = map f (zip2 [0..] (StrictListToList (PR_GetPaths project)))
f (n, p) = " [" +++ toString n +++ "] " +++ p
doProjectPathAction _ _ project ListPathsAction world = showLines ["Paths for project:" : showPaths project] world
doProjectPathAction cleanhome pn project (MovePathAction i pdir) world =
doModPaths cleanhome pn project (moveStrictListIdx i pdir) world
......@@ -306,6 +344,13 @@ doProjectPathAction _ _ _ _ world =
, " remove <i> : remove path <i> from the list of projects"
, " move <i> <up|down> : move path <i> up or down one position" ] world
/**
* Collect all project paths in a list with an index prefixed
*/
showPaths :: Project -> .[String]
showPaths project = map f (zip2 [0..] (StrictListToList (PR_GetPaths project)))
where f (n, p) = " [" +++ toString n +++ "] " +++ p
/**
* Modify the list of paths in a project given a modification function which
* takes a strict list of project paths and returns a strict list of project
......@@ -313,8 +358,7 @@ doProjectPathAction _ _ _ _ world =
*/
doModPaths :: String String Project .([!String!] -> [!String!]) *World -> .World
doModPaths cleanhome pn project f world
# (ok, world) = saveProject cleanhome prj pn world
| not ok = abort "Failed to modify project paths"
# world = saveProject cleanhome prj pn world
= showLines ["Successfully modified project paths"] world
where paths = PR_GetPaths project
prj = PR_SetPaths False paths (f paths) project
......@@ -322,17 +366,20 @@ doModPaths cleanhome pn project f world
/**
* Open a project file
*/
openProject :: !FilePath !FilePath !*World -> (!MaybeErrorString Project,!*World)
openProject :: !FilePath !FilePath !*World -> (!Project, !*World)
openProject cleanhome projectfile world
# ((prj, ok, err), world) = accFiles (ReadProjectFile projectfile cleanhome) world
| ok = (Ok prj, world)
= (Error err, world)
| ok = (prj, world)
= abort err
/**
* Save a project back to its project file
*/
saveProject :: !FilePath !Project !FilePath !*World -> (Bool, !*World)
saveProject cleanhome prj projectfile world = accFiles (SaveProjectFile projectfile prj cleanhome) world
saveProject :: !FilePath !Project !FilePath !*World -> !*World
saveProject cleanhome prj projectfile world
# (ok, world) = accFiles (SaveProjectFile projectfile prj cleanhome) world
| not ok = error "Error saving project" world
= world
/**
* Remove an item from a strict list at a given index. Abort execution if the
......@@ -351,12 +398,16 @@ moveStrictListIdx :: .Int .PathDirection .[!a!] -> .[!a!]
moveStrictListIdx i dir xs
| i < 0 || i > (LLength xs - 1) = abort ("Index " +++ toString i +++ " out of bounds")
| otherwise = ListToStrictList (msl dir (splitAt i (StrictListToList xs)))
where msl PathUp ([], xs) = xs
msl PathUp (xs, [x:ys]) = ((init xs) ++ [x : (last xs) : ys])
msl PathDown ([], [x:y:ys]) = [y:x:ys]
msl PathDown (xs, []) = xs
msl PathDown (xs, [y]) = xs ++ [y]
msl PathDown (xs, [x:y:ys]) = (xs ++ [y:x:ys])
where msl PathUp ([], xs) = xs
msl PathUp (xs, [x:ys]) = (init xs) ++ [x : (last xs) : ys]
msl PathDown ([], [x:y:ys]) = [y:x:ys]
msl PathDown (xs, []) = xs
msl PathDown (xs, [y]) = xs ++ [y]
msl PathDown (xs, [x:y:ys]) = xs ++ [y:x:ys]
msl PathTop (xs, []) = xs
msl PathTop (xs, [y:ys]) = [y:xs] ++ ys
msl PathBottom (xs, []) = xs
msl PathBottom (xs, [y:ys]) = xs ++ ys ++ [y]
/**
* Execute module-related actions
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment