Commit 8d8db4f8 authored by Jurrien Stutterheim's avatar Jurrien Stutterheim

CPM: Add ability to move paths up and down

parent e4003527
......@@ -36,8 +36,13 @@ import UtilStrictLists
= AddPathAction String
| RemovePathAction Int
| ListPathsAction
| MovePathAction Int PathDirection
| PathHelp
:: PathDirection
= PathUp
| PathDown
:: ModuleAction
= CreateModule ModuleType
| ModuleHelp
......@@ -58,18 +63,20 @@ spstrtok = sptoken o fromString
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)
pProjectAction = (spstrtok "create" <@ const CreateProject)
<|> (spstrtok "show" <@ const ShowProject)
<|> (spstrtok "build" &> pForce <&> \ f -> pIDEEnvs <@ BuildProject f)
<|> (spstrtok "path" &> pPathAction)
<!> (pHelp ProjectHelp)
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
pForce :: CParser Char Bool a
pForce = (spstrtok "--force" <@ const True) <|> (yield False)
......@@ -187,24 +194,34 @@ doProjectPathAction cleanhome pn project (AddPathAction path) world
where prj = PR_SetPaths False paths (path :! paths) project // TODO: Double check to see if PR_SetPaths is used correctly
paths = PR_GetPaths project
doProjectPathAction cleanhome pn project (RemovePathAction n) world
doProjectPathAction cleanhome pn project (RemovePathAction i) world
# (ok, world) = saveProject cleanhome prj pn world
| not ok = abort "Failed to remove path from project" // TODO: Improve
= showLines ["Path " +++ toString n +++ " successfully removed from project"] world
= showLines ["Path " +++ toString i +++ " successfully removed from project"] world
where paths = PR_GetPaths project
paths` = rmStrictListIdx n paths
paths` = rmStrictListIdx i paths
prj = PR_SetPaths False paths paths` project // TODO: Double check to see if PR_SetPaths is used correctly
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
// TODO: Refactor and combine with removepath and addpath
doProjectPathAction cleanhome pn project (MovePathAction i pdir) world
# (ok, world) = saveProject cleanhome prj pn world
| not ok = abort "Failed to move path" // TODO: Improve
= showLines ["Path " +++ toString i +++ " successfully moved"] world
where paths = PR_GetPaths project
paths` = moveStrictListIdx i pdir paths
prj = PR_SetPaths False paths paths` project // TODO: Double check to see if PR_SetPaths is used correctly
doProjectPathAction _ _ _ _ world =
help "cpm project <projectname> path <action>"
[ "Where <action> is one of the following"
, " add <path> : add a path to the project"
, " list : list all project paths"
, " remove <n> : remove path <n> from the list of projects"] world
, " add <path> : add a path to the project"
, " list : list all project paths and their index"
, " remove <i> : remove path <i> from the list of projects"
, " move <i> <up|down> : move path <i> up or down one position" ] world
openProject :: !FilePath !FilePath !*World -> (!MaybeErrorString Project,!*World)
openProject cleanhome projectfile world
......@@ -220,6 +237,17 @@ rmStrictListIdx 0 (_ :! t) = t
rmStrictListIdx n (h :! t) | n > 0 = h :! (rmStrictListIdx (n - 1) t)
rmStrictListIdx n _ = abort ("Index " +++ toString n +++ " out of bounds")
moveStrictListIdx :: !Int !PathDirection !(List String) -> List String
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])
doModuleAction :: .String .String .ModuleAction *World -> .World
doModuleAction cleanhome mn (CreateModule mt) world
# (dclexists, world) = fileExists dclnm world
......
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