rodrigosetti/master-plan
1
1
Fork 0
mirror of https://github.com/rodrigosetti/master-plan.git synced 2024-11-22 04:13:26 +03:00
Code Issues Projects Releases Wiki Activity

Update parser. Fixes #5

Browse Source
This commit is contained in:
Rodrigo Setti 2017-08-15 21:32:37 -07:00
parent 475b01ad9d
commit dd4f8bf6f9
No known key found for this signature in database
GPG Key ID: 3E2EB67B3A72ABD3
12 changed files with 275 additions and 242 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
README.md
View File

@ -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"
};
```

4
app/Main.hs
View File

@ -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

125
examples/example1.plan
View File

@ -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?"
};

BIN
examples/example1.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 192 KiB

After

Width:  |  Height:  |  Size: 138 KiB

17
src/MasterPlan/Backend/Graph.hs
View File

@ -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

85
src/MasterPlan/Backend/Identity.hs
View File

@ -11,76 +11,69 @@ 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 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
dependencies ∷ Binding → [ProjectKey]
dependencies = nub . everything (++) ([] `mkQ` collectDep)
where
collectDep (Reference n) = [n]
collectDep _ = []
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)
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) <> "%"
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)
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
@ -90,3 +83,9 @@ renderBinding projName (BindingExpr pr e) =
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 _ = []

17
src/MasterPlan/Data.hs
View File

@ -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

1
src/MasterPlan/Internal/Debug.hs
View File

@ -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.

158
src/MasterPlan/Parser.hs
View File

@ -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
runParser filename contents = case parse projectSystem filename contents of
Left e -> Left $ parseErrorPretty' contents e
Right v -> Right v

5
test/MasterPlan/Arbitrary.hs
View File

@ -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
in BindingAtomic <$> arbitrary
<*> elements [0, 1 .. 100]
<*> unitGen
<*> unitGen)
, (1, pure $ BindingPlaceholder defaultProjectProps) ]
<*> unitGen
shrink (BindingExpr pr e) = map (BindingExpr pr) $ shrink e
shrink _ = []

3
test/MasterPlan/DataSpec.hs
View File

@ -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

2
test/MasterPlan/ParserSpec.hs
View File

@ -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