diff --git a/README.md b/README.md index 17867cc..ba68491 100644 --- a/README.md +++ b/README.md @@ -14,7 +14,7 @@ These are the values propositions of master plan: * **Freedom**: master plan is a open specification, not dependent on tools or hosting. There is this current open-source implementation, but anyone can implement tools or visualizations on top of it. - + See the [wiki](https://github.com/rodrigosetti/master-plan/wiki) for details and examples. ## Algebra of Projects @@ -34,9 +34,9 @@ things depending on the domain, but most usually it's time. Given all these constraints and structure, master plan will build an optimum prioritization of projects and sub-projects for execution. -The entire definition of a project is defined into a single `.plan` file -using a simple C-like language. There are defaults for most constrains and properties -such that things can be less verbose if using the defaults. +The entire definition of a project is defined into a single `.plan` file using a +simple language. There are defaults for most constrains and properties such that +things can be less verbose if using the defaults. The tool is able to build visualizations from the plan file. @@ -70,18 +70,11 @@ Available options: ### Syntax -Comments are C-style: multiline in between `/*` and `*/`, and single line starts -with `//`, extending to the end of line. Every definition must end with semicolon (`;`). +Comments start with ">" and go until the end of line. -Everything else are definitions, in the form `lrs = rhs`. -There are two kinds of definitions with respect to `lrs` (left hand side): +Everything else are definitions, in the form `name [attributes] [expression] ;`. - * Definition of a project: in the form `identifier = expression` - * Definition of a property of a project: in the form `identifier(identifier) = expression`. - This is used to define properties of names. - -A project is identified by a unique identifier. The "root" project is identified -by a special `root` identifier. +A project name should be unique. Definitions end with semicolon. Project expressions are expressions where project identifiers are combined via binary operators. Parenthesis can be used to enforce operator precedence. There @@ -91,9 +84,12 @@ are three operators: * `p = a x b` - Product: `p` is executed when `a` and `b` is executed. * `p = a -> b` - Sequence: `p` is executed when `a` and `b` is executed, in order. -#### Properties +Please note that a equal sign (`=`) can be placed optionally just before the +definition of the expression. -Following is a list of supported properties of projects: +#### Attributes + +Following is a list of supported attributes of projects: | Property name | Expected Type | Description | |---------------|---------------|-------------| @@ -101,23 +97,37 @@ Following is a list of supported properties of projects: | description | text | longer description of what the project is | | url | URL | reference in the web for more context about the project | | owner | username | name of the person responsible for execution | -| progress | percentage | how much progress has been made so far | -| cost | number | estimated cost | -| trust | percentage | probability of success | +| progress | percentage | how much progress has been made so far (default 0%) | +| cost | number | estimated cost (default 0) | +| trust | percentage | probability of success (default 100%) | -#### Grammar +Attributes can be specified between brackets, like, _e.g._: ``` -plan = (definition ";")* -definition = project_def | predicate_def - -project_def = identifier "=" expression -expression = term (("->" | "*") term)* -term = factor ("+" factor)* -factor = "(" expression ")" | identifier - -predicate_def = identifier "(" identifier ")" "=" value -value = percentage | literalString - -percentage = nonNegativeNumber "%" +b { + title "build" + description "our technology can be built and scale" +} phase1 -> phase2 -> phase3; +``` + +Or, optionally, if only "title" is define, as a single string literal, as _e.g._: + +``` +approvalProcess "approval process" legal -> budget -> executive; +``` + +There are "atomic" attributes that should be defined only for projects without +expressions: "cost", "trust", and "progress". Defining them and also expressions +is an error. + +Example of atomic project: + +``` +sb { + title "supplier B" + trust 60% + cost 5 + url "www.supplier.b.com" + owner "partnerships" +}; ``` diff --git a/app/Main.hs b/app/Main.hs index 353cf7d..0ea1aad 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -73,10 +73,10 @@ cmdParser = Opts <$> optional (strArgument ( help "plan file to read from (defau <*> (invertProps <$> many (option property ( long "hide" <> help "hide a particular property" <> metavar (intercalate "|" $ map fst propertyNames)))) - propertyNames = map (\p -> (show p, p)) [minBound :: ProjProperty ..] + propertyNames = map (\p -> (show p, p)) [minBound :: ProjAttribute ..] property = readEnum propertyNames - invertProps ∷ [ProjProperty] → [ProjProperty] + invertProps ∷ [ProjAttribute] → [ProjAttribute] invertProps l = filter (`notElem` l) $ map snd propertyNames filterParser ∷ Parser ProjFilter diff --git a/examples/example1.plan b/examples/example1.plan index 8ebe84e..aa0896a 100644 --- a/examples/example1.plan +++ b/examples/example1.plan @@ -1,64 +1,93 @@ -/** - * This project is a business plan, which vision is state in - * the "root" project - which is run a successful tech-based - * business in a certain market. - */ -title(root) = "business"; -description(root) = "can we run a successful business"; -owner(root) = "CEO"; +> This project is a business plan, which vision is state in +> the "root" project - which is run a successful tech-based +> business in a certain market. -root = x + p; +root { + title "business" + description "can we run a successful business" + owner "CEO" +} x + p; -// ------- +x { + title "build technology" + description "can we build the technology ourselves" +} h * b; -title(x) = "build technology"; -description(x) = "can we build the technology ourselves"; +h hire + acquihire; -x = h * b; +hire { + title "hire" + description "can we attract and retain talent" + cost 20 + owner "HR" + trust 50% +}; -title(h) = "hire"; -description(h) = "can we attract and retain talent"; -cost(h) = 20; -owner(h) = "HR"; +acquihire { + description "can we buy talent" + cost 100 + owner "HR" + trust 100% +}; -title(b) = "build"; -description(b) = "our technology can be built and scale"; +b { + title "build" + description "our technology can be built and scale" +} phase1 -> phase2 -> phase3; -b = phase1 -> phase2 -> phase3; +phase1 { + title "validate prototype" + trust 70% + progress 100% + owner "engineering" +}; -title(phase1) = "validate prototype"; -trust(phase1) = 70%; -progress(phase1) = 100%; -owner(phase1) = "engineering"; +phase2 { + title "launch in small market" + trust 50% + progress 32% + owner "engineering" +}; -title(phase2) = "launch in small market"; -trust(phase2) = 50%; -progress(phase2) = 32%; -owner(phase2) = "engineering"; +phase3 { + title "scale nationwide" + trust 20% + owner "engineering" +}; -title(phase3) = "scale nationwide"; -trust(phase3) = 20%; -owner(phase3) = "engineering"; +> Another way to get technology is to parner, +> instead of building it: -// Another way to get technology is to parner, -// instead of building it: +p { + title "tech partner" + description "secure a tech partnership" +} (approvalProcess -> sa) + (approvalProcess -> sb); -title(p) = "tech partner"; -description(p) = "secure a tech partnership"; +sa { + title "supplier A" + trust 90% + cost 10 + url "www.supplier.a.com" + owner "partnerships" +}; -p = (approvalProcess -> sa) + (approvalProcess -> sb); +sb { + title "supplier B" + trust 60% + cost 5 + url "www.supplier.b.com" + owner "partnerships" +}; -title(sa) = "supplier A"; trust(sa) = 90%; cost(sa) = 10; -url(sa) = "www.supplier.a.com"; -owner(sa) = "partnerships"; +> Approval process is a sub-project we have to go once +> regardless of which partnership, will "open the way" -title(sb) = "supplier B"; trust(sb) = 60%; cost(sb) = 5; -url(sb) = "www.supplier.b.com"; -owner(sb) = "partnerships"; +approvalProcess "approval process" legal -> budget -> executive; -/* - * Approval process is a sub-project we have to go once - * regardless of which partnership, will "open the way" - */ -approvalProcess = legal -> budget -> executive; -title(approvalProcess) = "approval process"; +legal { + description "figure out how to write the contract" +}; + +budget { + description "can we afford?" +}; diff --git a/examples/example1.png b/examples/example1.png index ae2001f..f36c620 100644 Binary files a/examples/example1.png and b/examples/example1.png differ diff --git a/src/MasterPlan/Backend/Graph.hs b/src/MasterPlan/Backend/Graph.hs index 0b54d30..1ade2b9 100644 --- a/src/MasterPlan/Backend/Graph.hs +++ b/src/MasterPlan/Backend/Graph.hs @@ -64,11 +64,6 @@ toRenderModel sys rootK = case M.lookup rootK (bindings sys) of bindingToRM key (BindingAtomic prop c t p) = pure $ mkLeaf $ PNode (Just key) (Just prop) c t p - bindingToRM key (BindingPlaceholder prop) = pure $ mkLeaf $ PNode (Just key) - (Just prop) - defaultCost - defaultTrust - defaultProgress mkNode :: (PNode -> [RenderModel] -> RenderModel) -> ProjectExpr @@ -104,7 +99,7 @@ data RenderOptions = RenderOptions { colorByProgress :: Bool -- ^Whether to colo , renderWidth :: Integer -- ^The width of the output image , renderHeight :: Integer -- ^The height of the output image , rootKey :: ProjectKey -- ^The name of the root project - , whitelistedProps :: [ProjProperty] -- ^Properties that should be rendered + , whitelistedProps :: [ProjAttribute] -- ^Properties that should be rendered } deriving (Eq, Show) -- | The main rendering function @@ -114,7 +109,7 @@ render fp (RenderOptions colorByP w h rootK props) sys = dia = fromMaybe noRootEroor $ renderTree colorByP props <$> evalState (toRenderModel sys rootK) [] in renderRasterific fp (dims2D (fromInteger w) (fromInteger h)) $ bgFrame 1 white $ centerXY dia -renderTree :: Bool -> [ProjProperty] -> RenderModel -> QDiagram B V2 Double Any +renderTree :: Bool -> [ProjAttribute] -> RenderModel -> QDiagram B V2 Double Any renderTree colorByP props (Node (_, n) []) = alignL $ renderNode colorByP props n renderTree colorByP props x@(Node (ty, n) ts@(t:_)) = (strutY (12 * treeSize x) <> alignL (centerY $ renderNode colorByP props n)) @@ -140,7 +135,7 @@ renderTree colorByP props x@(Node (ty, n) ts@(t:_)) = AtomicNode -> mempty in txt # fontSizeL 2 # bold <> circle 2 # fc white # lwO 1 -renderNode :: Bool -> [ProjProperty] -> PNode -> QDiagram B V2 Double Any +renderNode :: Bool -> [ProjAttribute] -> PNode -> QDiagram B V2 Double Any renderNode _ _ (NodeRef n) = text n <> roundedRect 30 12 0.5 # lwO 2 # fc white # dashingN [0.005, 0.005] 0 renderNode colorByP props (PNode _ prop c t p) = @@ -156,7 +151,7 @@ renderNode colorByP props (PNode _ prop c t p) = sectionsWithSep = vcat (intersperse (hrule 30 # dashingN [0.005, 0.005] 0 # lwO 1) sections) in outerRect # fcColor `beneath` centerY sectionsWithSep - givenProp :: ProjProperty -> Maybe a -> Maybe a + givenProp :: ProjAttribute -> Maybe a -> Maybe a givenProp pro x = if pro `elem` props then x else Nothing headerSection = case [progressHeader, titleHeader, costHeader] of @@ -167,8 +162,8 @@ renderNode colorByP props (PNode _ prop c t p) = costHeader = givenProp PCost $ Just $ displayCost c # translateX 14 descriptionSection, urlSection, bottomSection :: Maybe (QDiagram B V2 Double Any) - descriptionSection = givenProp PDescription $ prop >>= description >>= (pure . text) -- TODO line breaks - urlSection = givenProp PUrl $ prop >>= url >>= (pure . text) -- TODO ellipsis + descriptionSection = givenProp PDescription $ prop >>= description >>= (pure . text) -- TODO:50 line breaks + urlSection = givenProp PUrl $ prop >>= url >>= (pure . text) -- TODO:40 ellipsis bottomSection = case [trustSubSection, ownerSubSection] of [Nothing, Nothing] -> Nothing diff --git a/src/MasterPlan/Backend/Identity.hs b/src/MasterPlan/Backend/Identity.hs index 8837885..2eced70 100644 --- a/src/MasterPlan/Backend/Identity.hs +++ b/src/MasterPlan/Backend/Identity.hs @@ -11,82 +11,81 @@ Portability : POSIX {-# LANGUAGE OverloadedStrings #-} module MasterPlan.Backend.Identity (render) where -import Control.Monad (when, void) -import Control.Monad.RWS (RWS, evalRWS, gets, tell, modify, asks) +import Control.Monad (when) +import Control.Monad.RWS (RWS, evalRWS, gets, tell, modify) import Data.Generics import Data.List (nub) import qualified Data.List.NonEmpty as NE import qualified Data.Map as M -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) import qualified Data.Text as T -import Data.Maybe (fromMaybe) +import Data.Maybe (isJust) import MasterPlan.Data -- |Plain text renderer -render ∷ ProjectSystem → [ProjProperty] -> T.Text +render ∷ ProjectSystem → [ProjAttribute] -> T.Text render (ProjectSystem bs) whitelist = snd $ evalRWS (renderName "root" >> renderRest) whitelist bs where renderRest = gets M.keys >>= mapM_ renderName -type RenderMonad = RWS [ProjProperty] T.Text (M.Map String Binding) - -renderLine ∷ T.Text → RenderMonad () -renderLine s = tell $ s <> ";\n" +type RenderMonad = RWS [ProjAttribute] T.Text (M.Map String Binding) renderName ∷ ProjectKey → RenderMonad () renderName projName = do mb <- gets $ M.lookup projName case mb of Nothing -> pure () - Just b -> do rendered <- renderBinding projName b - when rendered $ tell "\n" -- empty line to separate bindings + Just b -> do tell $ T.pack projName + when (hasAttribute b) $ do + tell " {\n" + renderAttr b + tell "}" + case b of + BindingExpr _ e -> tell $ " " <> expressionToStr False e <> ";\n" + _ -> tell ";\n" modify $ M.delete projName mapM_ renderName $ dependencies b + where + hasAttribute (BindingExpr props _) = hasProperty props + hasAttribute (BindingAtomic props c t p) = hasProperty props + || c /= defaultCost + || t /= defaultTrust + || p /= defaultProgress + hasProperty props = title props /= projName + || isJust (description props) + || isJust (owner props) + || isJust (url props) + + percentage n = T.pack $ show (n * 100) <> "%" + + renderAttr (BindingExpr props _) = renderProps props + renderAttr (BindingAtomic props c t p) = + do renderProps props + when (c /= defaultCost) $ tell $ "cost " <> T.pack (show c) <> "\n" + when (t /= defaultTrust) $ tell $ "trust " <> percentage t <> "\n" + when (p /= defaultProgress) $ tell $ "progress " <> percentage p <> "\n" + + renderProps :: ProjectProperties -> RenderMonad () + renderProps p = do let maybeRender :: T.Text -> Maybe String -> RenderMonad () + maybeRender n = maybe (pure ()) (\x -> tell $ n <> " " <> T.pack (show x) <> "\n") + when (title p /= projName) $ tell $ "title " <> T.pack (show $ title p) <> "\n" + maybeRender "description" (description p) + maybeRender "url" (url p) + maybeRender "owner" (owner p) + + combinedEToStr parens op ps = let sube = map (expressionToStr True) $ NE.toList ps + s = T.intercalate (" " <> op <> " ") sube + in if parens && length ps > 1 then "(" <> s <> ")" else s + + expressionToStr :: Bool -> ProjectExpr -> T.Text + expressionToStr _ (Reference n) = T.pack n + expressionToStr parens (Product ps) = combinedEToStr parens "*" ps + expressionToStr parens (Sequence ps) = combinedEToStr parens "->" ps + expressionToStr parens (Sum ps) = combinedEToStr parens "+" ps dependencies ∷ Binding → [ProjectKey] dependencies = nub . everything (++) ([] `mkQ` collectDep) where collectDep (Reference n) = [n] collectDep _ = [] - -renderProps ∷ String → ProjectProperties → RenderMonad Bool -renderProps projName p = - or <$> sequence [ renderProperty projName PTitle (title p) projName (T.pack . show) - , renderProperty projName PDescription (description p) Nothing (T.pack . show . fromMaybe "") - , renderProperty projName PUrl (url p) Nothing (T.pack . show . fromMaybe "") - , renderProperty projName POwner (owner p) Nothing (T.pack . show . fromMaybe "") ] - -renderProperty ∷ Eq a ⇒ ProjectKey → ProjProperty → a → a → (a → T.Text) → RenderMonad Bool -renderProperty projName prop val def toText - | val == def = pure False - | otherwise = do whitelisted <- asks (prop `elem`) - when whitelisted $ - renderLine $ T.pack (show prop) <> "(" <> T.pack projName <> ") = " <> toText val - pure whitelisted - -renderBinding ∷ ProjectKey → Binding → RenderMonad Bool -renderBinding projName (BindingPlaceholder p) = renderProps projName p -renderBinding projName (BindingAtomic props c t p) = - or <$> sequence [ renderProps projName props - , renderProperty projName PCost c 0 (T.pack . show) - , renderProperty projName PTrust t 1 percentage - , renderProperty projName PProgress p 0 percentage ] - where - percentage n = T.pack $ show (n * 100) <> "%" - - -renderBinding projName (BindingExpr pr e) = - do void $ renderProps projName pr - renderLine $ T.pack projName <> " = " <> expressionToStr False e - pure True - where - combinedEToStr parens op ps = let sube = map (expressionToStr True) $ NE.toList ps - s = T.intercalate (" " <> op <> " ") sube - in if parens && length ps > 1 then "(" <> s <> ")" else s - - expressionToStr :: Bool -> ProjectExpr -> T.Text - expressionToStr _ (Reference n) = T.pack n - expressionToStr parens (Product ps) = combinedEToStr parens "*" ps - expressionToStr parens (Sequence ps) = combinedEToStr parens "->" ps - expressionToStr parens (Sum ps) = combinedEToStr parens "+" ps diff --git a/src/MasterPlan/Data.hs b/src/MasterPlan/Data.hs index a6fdcad..0fda5c5 100644 --- a/src/MasterPlan/Data.hs +++ b/src/MasterPlan/Data.hs @@ -15,7 +15,7 @@ module MasterPlan.Data ( ProjectExpr(..) , ProjectSystem(..) , Binding(..) , ProjectKey - , ProjProperty(..) + , ProjAttribute(..) , Trust , Cost , Progress @@ -57,7 +57,6 @@ data ProjectExpr = Sum (NE.NonEmpty ProjectExpr) -- properties data Binding = BindingAtomic ProjectProperties Cost Trust Progress | BindingExpr ProjectProperties ProjectExpr - | BindingPlaceholder ProjectProperties deriving (Eq, Show, Data, Typeable) -- |Any binding (with a name) may have associated properties @@ -67,10 +66,10 @@ data ProjectProperties = ProjectProperties { title :: String , owner :: Maybe String } deriving (Eq, Show, Data, Typeable) -data ProjProperty = PTitle | PDescription | PUrl | POwner | PCost | PTrust | PProgress +data ProjAttribute = PTitle | PDescription | PUrl | POwner | PCost | PTrust | PProgress deriving (Eq, Enum, Bounded) -instance Show ProjProperty where +instance Show ProjAttribute where show PTitle = "title" show PDescription = "description" show PUrl = "url" @@ -105,15 +104,13 @@ defaultTaskProj pr = BindingAtomic pr defaultCost defaultTrust defaultProgress bindingTitle ∷ Binding → String bindingTitle (BindingAtomic ProjectProperties { title=t} _ _ _) = t bindingTitle (BindingExpr ProjectProperties { title=t} _) = t -bindingTitle (BindingPlaceholder ProjectProperties { title=t}) = t -- | Expected cost cost ∷ ProjectSystem → ProjectExpr → Cost cost sys (Reference n) = case M.lookup n (bindings sys) of Just (BindingAtomic _ c _ p) -> c * (1-p) -- cost is weighted by remaining progress - Just (BindingExpr _ p) -> cost sys p -- TODO: avoid cyclic - Just (BindingPlaceholder _) -> defaultCost -- mentioned but no props neither task defined + Just (BindingExpr _ p) -> cost sys p -- TODO:0 avoid cyclic Nothing -> defaultCost -- mentioned but no props neither task defined cost sys (Sequence ps) = costConjunction sys ps cost sys (Product ps) = costConjunction sys ps @@ -135,8 +132,7 @@ trust ∷ ProjectSystem → ProjectExpr → Trust trust sys (Reference n) = case M.lookup n (bindings sys) of Just (BindingAtomic _ _ t p) -> p + t * (1-p) - Just (BindingExpr _ p) -> trust sys p -- TODO: avoid cyclic - Just (BindingPlaceholder _) -> defaultTrust -- mentioned but no props neither task defined + Just (BindingExpr _ p) -> trust sys p -- TODO:10 avoid cyclic Nothing -> defaultTrust -- mentioned but no props neither task defined trust sys (Sequence ps) = trustConjunction sys ps trust sys (Product ps) = trustConjunction sys ps @@ -150,8 +146,7 @@ progress ∷ ProjectSystem → ProjectExpr → Progress progress sys (Reference n) = case M.lookup n (bindings sys) of Just (BindingAtomic _ _ _ p) -> p - Just (BindingExpr _ p) -> progress sys p -- TODO: avoid cyclic - Just (BindingPlaceholder _) -> defaultProgress -- props without task or expression + Just (BindingExpr _ p) -> progress sys p -- TODO:20 avoid cyclic Nothing -> defaultProgress -- mentioned but no props neither task defined progress sys (Sequence ps) = progressConjunction sys ps progress sys (Product ps) = progressConjunction sys ps diff --git a/src/MasterPlan/Internal/Debug.hs b/src/MasterPlan/Internal/Debug.hs index e7d1599..c168bc1 100644 --- a/src/MasterPlan/Internal/Debug.hs +++ b/src/MasterPlan/Internal/Debug.hs @@ -26,7 +26,6 @@ debugSys sys@(ProjectSystem bs) = void $ M.traverseWithKey printBinding bs case b of BindingExpr _ e -> putStr "\n" >> debugProj sys e BindingAtomic _ c t p -> putStrLn $ printf "(c:%.2f,t:%.2f,p:%2.f)" c t p - BindingPlaceholder _ -> putStrLn "?" -- |Print a Project Expression in a Project System to standard output. -- The expression is printed in a tree like fashion. diff --git a/src/MasterPlan/Parser.hs b/src/MasterPlan/Parser.hs index 973794d..f6a7220 100644 --- a/src/MasterPlan/Parser.hs +++ b/src/MasterPlan/Parser.hs @@ -13,10 +13,12 @@ Portability : POSIX module MasterPlan.Parser (runParser) where import Control.Monad.State -import Data.Generics +import Control.Applicative (empty) +import Data.Generics hiding (empty) import Data.List (nub) import qualified Data.List.NonEmpty as NE import qualified Data.Map as M +import Data.Maybe (fromMaybe, isJust) import qualified Data.Text as T import Data.Void import MasterPlan.Data @@ -25,14 +27,11 @@ import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L import Text.Megaparsec.Expr -type Parser = ParsecT Void T.Text (State ProjectSystem) +type Parser = Parsec Void T.Text -- |Space consumer sc ∷ Parser () -sc = L.space space1 lineCmnt blockCmnt - where - lineCmnt = L.skipLineComment "//" - blockCmnt = L.skipBlockComment "/*" "*/" +sc = L.space space1 (L.skipLineComment ">") empty lexeme ∷ Parser a → Parser a lexeme = L.lexeme sc @@ -46,12 +45,14 @@ parens = between (symbol "(") (symbol ")") -- |list of reserved words rws ∷ [String] -rws = map show [minBound :: ProjProperty ..] +rws = map show [minBound :: ProjAttribute ..] identifier ∷ Parser String -identifier = (lexeme . try) (p >>= check) +identifier = (lexeme . try) $ (:) <$> letterChar <*> many alphaNumChar + +nonKeywordIdentifier :: Parser String +nonKeywordIdentifier = identifier >>= check where - p = (:) <$> letterChar <*> many alphaNumChar check x | x `elem` rws = fail $ "keyword " ++ show x ++ " cannot be an identifier" | otherwise = pure x @@ -68,67 +69,11 @@ percentage = do n <- L.float "percentage value" nonNegativeNumber :: Parser Float nonNegativeNumber = L.float -definition ∷ Parser () -definition = - choice ([ propsProp PTitle stringLiteral (\v p -> p { title = v }) - , propsProp PDescription stringLiteral (\v p -> p { description = Just v}) - , propsProp PUrl stringLiteral (\v p -> p { url = Just v}) - , propsProp POwner stringLiteral (\v p -> p { owner = Just v}) - , taskProp PCost nonNegativeNumber (\v b -> case b of BindingAtomic r _ t p -> BindingAtomic r v t p; _ -> b) - , taskProp PTrust percentage (\v b -> case b of BindingAtomic r c _ p -> BindingAtomic r c v p; _ -> b) - , taskProp PProgress percentage (\v b -> case b of BindingAtomic r c t _ -> BindingAtomic r c t v; _ -> b) - , structure ] :: [Parser ()]) - where - structure :: Parser () - structure = do projName <- identifier - projectExpr <- symbol "=" *> expressionParser - sys <- lift get - - -- check if it's recursive - let deps = dependencies sys projectExpr - when (projName `elem` deps) $ fail $ "definition of \"" ++ projName ++ "\" is recursive" - - let binding = M.lookup projName $ bindings sys - newBinding <- case binding of - Nothing -> pure $ BindingExpr (defaultProjectProps { title=projName }) projectExpr - Just BindingExpr {} -> fail $ "Redefinition of \"" ++ projName ++ "\"." - Just (BindingPlaceholder p) -> pure $ BindingExpr p projectExpr - Just BindingAtomic {} -> fail $ "ProjectExpr \"" ++ projName ++ "\" is atomic" - - lift $ put $ sys { bindings = M.insert projName newBinding $ bindings sys } - - propsProp :: ProjProperty -> Parser a -> (a -> ProjectProperties -> ProjectProperties) -> Parser () - propsProp prop valueParser modifier = - property prop valueParser setter - where - setter projName val Nothing = pure $ BindingPlaceholder $ modifier val $ defaultProjectProps { title=projName } - setter _ val (Just p) = pure $ everywhere (mkT $ modifier val) p - - taskProp :: ProjProperty -> Parser a -> (a -> Binding -> Binding) -> Parser () - taskProp prop valueParser modifier = - property prop valueParser setter - where - setter projName val Nothing = pure $ modifier val $ defaultTaskProj defaultProjectProps { title=projName } - setter projName _ (Just BindingExpr {}) = fail $ "ProjectExpr \"" ++ projName ++ "\" is not atomic." - setter _ val (Just (BindingPlaceholder p)) = pure $ modifier val $ defaultTaskProj p - setter _ val (Just p@BindingAtomic {}) = pure $ modifier val p - - property ∷ ProjProperty → Parser a → (String -> a -> Maybe Binding -> Parser Binding) -> Parser () - property prop valueParser setter = - do void $ symbol $ T.pack $ show prop - projName <- parens identifier - mBinding <- lift $ M.lookup projName <$> gets bindings - value <- symbol "=" *> valueParser - newBinding <- setter projName value mBinding - let modifySys :: ProjectSystem -> ProjectSystem - modifySys sys = sys { bindings = M.insert projName newBinding $ bindings sys } - lift $ modify modifySys - -expressionParser ∷ Parser ProjectExpr -expressionParser = +expression ∷ Parser ProjectExpr +expression = simplifyProj <$> makeExprParser term table "expression" where - term = parens expressionParser <|> (Reference <$> identifier) + term = parens expression <|> (Reference <$> nonKeywordIdentifier) table = [[binary "*" (combineWith Product)] ,[binary "->" (combineWith Sequence)] ,[binary "+" (combineWith Sum)]] @@ -137,7 +82,63 @@ expressionParser = combineWith :: (NE.NonEmpty ProjectExpr -> ProjectExpr) -> ProjectExpr -> ProjectExpr -> ProjectExpr combineWith c p1 p2 = c $ p1 NE.<| [p2] -dependencies ∷ ProjectSystem -> ProjectExpr → [ProjectKey] + +binding :: ProjectKey -> Parser Binding +--binding key = do (props, mc, mt, mp) <- bracketAttributes +binding key = do (props, mc, mt, mp) <- try simpleTitle <|> try bracketAttributes <|> noAttributes + case (mc, mt, mp) of + (Nothing, Nothing, Nothing) -> + try (BindingExpr props <$> (sc *> optional (symbol "=") *> expression)) <|> + pure (BindingAtomic props defaultCost defaultTrust defaultProgress) + (mc', mt', mp') -> pure $ BindingAtomic props + (fromMaybe defaultCost mc') + (fromMaybe defaultTrust mt') + (fromMaybe defaultProgress mp') + where + attrKey :: Parser ProjAttribute + attrKey = do n <- identifier "attribute name" + case lookup n [(show a, a) | a <- [minBound::ProjAttribute ..]] of + Nothing -> fail $ "invalid attribute: \"" ++ n ++ "\"" + Just a -> pure a + + simpleTitle, bracketAttributes, noAttributes :: Parser (ProjectProperties, Maybe Cost, Maybe Trust, Maybe Progress) + simpleTitle = do s <- stringLiteral "title" + pure (defaultProjectProps {title=s}, Nothing, Nothing, Nothing) + + bracketAttributes = symbol "{" *> attributes (defaultProjectProps {title=key}) Nothing Nothing Nothing + + noAttributes = pure (defaultProjectProps {title=key}, Nothing, Nothing, Nothing) + + attributes :: ProjectProperties -> Maybe Cost -> Maybe Trust -> Maybe Progress + -> Parser (ProjectProperties, Maybe Cost, Maybe Trust, Maybe Progress) + attributes props mc mt mp = + try (sc *> symbol "}" *> pure (props, mc, mt, mp)) <|> + do attr <- sc *> attrKey + case attr of + PTitle -> do s <- stringLiteral "title" + attributes (props {title=s}) mc mt mp + PDescription -> do when (isJust $ description props) $ fail "redefinition of description" + s <- stringLiteral "description" + attributes (props {description=Just s}) mc mt mp + PUrl -> do when (isJust $ url props) $ fail "redefinition of url" + s <- stringLiteral "url" + attributes (props {url=Just s}) mc mt mp + POwner -> do when (isJust $ owner props) $ fail "redefinition of owner" + s <- stringLiteral "owner" + attributes (props {owner=Just s}) mc mt mp + PCost -> do when (isJust mc) $ fail "redefinition of cost" + c <- nonNegativeNumber "cost" + attributes props (Just c) mt mp + PTrust -> do when (isJust mt) $ fail "redefinition of cost" + t <- percentage "trust" + attributes props mc (Just t) mp + PProgress -> do when (isJust mp) $ fail "redefinition of progress" + p <- percentage "progress" + attributes props mc mt (Just p) + + +-- find out all the names that a particular binding references +dependencies ∷ ProjectSystem -> Binding → [ProjectKey] dependencies sys = everything (++) ([] `mkQ` collectDep) where collectDep (Reference n) = nub $ n : everything (++) ([] `mkQ` collectDep) (M.lookup n $ bindings sys) @@ -145,15 +146,22 @@ dependencies sys = everything (++) ([] `mkQ` collectDep) projectSystem :: Parser ProjectSystem projectSystem = - do between sc eof definitionSeq - lift get + mkProjSystem <$> definitions [] where - definitionSeq = void $ endBy1 definition (symbol ";") + mkProjSystem = ProjectSystem . M.fromList + definitions ds = do key <- sc *> nonKeywordIdentifier "project key" + when (key `elem` map fst ds) $ fail $ "redefinition of \"" ++ key ++ "\"" + b <- binding key <* symbol ";" + + -- check if it's recursive + let deps = dependencies (mkProjSystem ds) b + when (key `elem` deps) $ fail $ "definition of \"" ++ key ++ "\" is recursive" + + let ds' = (key,b):ds + (try eof *> pure ds') <|> definitions ds' runParser :: FilePath -> T.Text -> Either String ProjectSystem -runParser filename contents = let mr = runParserT projectSystem filename contents - initialPS = ProjectSystem M.empty - in case evalState mr initialPS of - Left e -> Left $ parseErrorPretty' contents e - Right v -> Right v +runParser filename contents = case parse projectSystem filename contents of + Left e -> Left $ parseErrorPretty' contents e + Right v -> Right v diff --git a/test/MasterPlan/Arbitrary.hs b/test/MasterPlan/Arbitrary.hs index b0d9bf6..f4c242c 100644 --- a/test/MasterPlan/Arbitrary.hs +++ b/test/MasterPlan/Arbitrary.hs @@ -43,11 +43,10 @@ instance Arbitrary Binding where -- to avoid generating cycles arbitrary = let unitGen = elements [0.0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1.0] - in frequency [ (50, BindingAtomic <$> arbitrary - <*> elements [0, 1 .. 100] - <*> unitGen - <*> unitGen) - , (1, pure $ BindingPlaceholder defaultProjectProps) ] + in BindingAtomic <$> arbitrary + <*> elements [0, 1 .. 100] + <*> unitGen + <*> unitGen shrink (BindingExpr pr e) = map (BindingExpr pr) $ shrink e shrink _ = [] diff --git a/test/MasterPlan/DataSpec.hs b/test/MasterPlan/DataSpec.hs index 91385c1..38ac35d 100644 --- a/test/MasterPlan/DataSpec.hs +++ b/test/MasterPlan/DataSpec.hs @@ -27,8 +27,7 @@ simulate sys (Reference n) = effectiveTrust = p + t * remainingProgress effectiveCost = c * remainingProgress pure (effectiveTrust > r, effectiveCost) - Just (BindingExpr _ p) -> simulate sys p -- TODO: avoid cyclic - Just (BindingPlaceholder _) -> pure (True, defaultCost) + Just (BindingExpr _ p) -> simulate sys p -- TODO:30 avoid cyclic Nothing -> pure (True, defaultCost) simulate sys (Sequence ps) = simulateConjunction sys $ NE.toList ps diff --git a/test/MasterPlan/ParserSpec.hs b/test/MasterPlan/ParserSpec.hs index 6c7b532..237f268 100644 --- a/test/MasterPlan/ParserSpec.hs +++ b/test/MasterPlan/ParserSpec.hs @@ -17,7 +17,7 @@ spec ∷ Spec spec = describe "parser" $ do - let allProps = [minBound :: ProjProperty ..] + let allProps = [minBound :: ProjAttribute ..] prop "rendered should be parseable" $ do let renderedIsParseable ∷ ProjectSystem → Property