master-plan 0.1.0.0 → 0.2.0.0
raw patch · 14 files changed
+1041/−950 lines, 14 filessetup-changed
Files
- LICENSE +21/−21
- README.md +134/−123
- Setup.hs +2/−2
- app/Main.hs +15/−14
- master-plan.cabal +81/−81
- src/MasterPlan/Backend/Graph.hs +236/−200
- src/MasterPlan/Backend/Identity.hs +92/−92
- src/MasterPlan/Data.hs +46/−39
- src/MasterPlan/Internal/Debug.hs +8/−5
- src/MasterPlan/Parser.hs +167/−159
- test/MasterPlan/Arbitrary.hs +67/−67
- test/MasterPlan/DataSpec.hs +147/−145
- test/MasterPlan/ParserSpec.hs +24/−1
- test/Spec.hs +1/−1
LICENSE view
@@ -1,21 +1,21 @@-MIT License - -Copyright (c) 2017 Rodrigo Setti - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. +MIT License++Copyright (c) 2017 Rodrigo Setti++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
README.md view
@@ -1,123 +1,134 @@-# master-plan - -[](https://travis-ci.org/rodrigosetti/master-plan) - -Master Plan is a text based project management tool that implements an -algebra of projects. - -These are the values propositions of master plan: - - * **Simplicity**: keep project management into a single text file. Under version control, - close to your code. - * **Agility**: embrace change, by allowing projects to specify uncertainty and allow - for refinement anytime. - * **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 - -In the algebra of projects, a project is an expression of sub-projects -combined using dependency operators. These operators define how sub-projects -relate to the higher-level projects in terms of execution and structural -dependency, that is, in which order (if any) the sub-projects must be executed, -and also whether all or some of the sub-projects must be executed at all. - -At some level, sub-projects will be small enough that they don't break down -further, in this case, they consist of a unit of execution. - -There is also the notion cost estimation and risk. Cost may mean different -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 tool is able to build visualizations from the plan file. - -Ideally, the plan file should be kept in version control so that execution and -planning progress can be recorded. - -### Command line Arguments - -``` -master-plan - project management tool for hackers - -Usage: master-plan [FILENAME] [-o|--output FILENAME] [--progress-below N] - [-c|--color] [-w|--width NUMBER] [--height NUMBER] - [-r|--root NAME] - [--hide title|description|url|owner|cost|trust|progress] - See documentation on how to write project plan files - -Available options: - FILENAME plan file to read from (default from stdin) - -o,--output FILENAME output file name (.png, .tif, .bmp, .jpg and .pdf - supported) - --progress-below N only display projects which progress is < N% - -c,--color color each project by progress - -w,--width NUMBER width of the output image - --height NUMBER height of the output image - -r,--root NAME name of the root project definition (default: "root") - --hide title|description|url|owner|cost|trust|progress - hide a particular property - -h,--help Show this help text -``` - -### 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 (`;`). - -Everything else are definitions, in the form `lrs = rhs`. -There are two kinds of definitions with respect to `lrs` (left hand side): - - * 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. - -Project expressions are expressions where project identifiers are combined via -binary operators. Parenthesis can be used to enforce operator precedence. There -are three operators: - - * `p = a + b` - Sum: `p` is executed when `a` or `b` is executed. - * `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 - -Following is a list of supported properties of projects: - -| Property name | Expected Type | Description | -|---------------|---------------|-------------| -| title | text | title of the project | -| 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 | - -#### Grammar - -``` -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 "%" -``` +# master-plan++[](https://travis-ci.org/rodrigosetti/master-plan)++Master Plan is a text based project management tool that implements an+algebra of projects.++These are the values propositions of master plan:++ * **Simplicity**: keep project management into a single text file. Under version control,+ close to your code.+ * **Agility**: embrace change, by allowing projects to specify uncertainty and allow+ for refinement anytime.+ * **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++In the algebra of projects, a project is an expression of sub-projects+combined using dependency operators. These operators define how sub-projects+relate to the higher-level projects in terms of execution and structural+dependency, that is, in which order (if any) the sub-projects must be executed,+and also whether all or some of the sub-projects must be executed at all.++At some level, sub-projects will be small enough that they don't break down+further, in this case, they consist of a unit of execution.++There is also the notion cost estimation and risk. Cost may mean different+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 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.++Ideally, the plan file should be kept in version control so that execution and+planning progress can be recorded.++### Command line Arguments++```+master-plan - project management tool for hackers++Usage: master-plan [FILENAME] [-o|--output FILENAME] [--progress-below N]+ [-c|--color] [-w|--width NUMBER] [--height NUMBER]+ [-r|--root NAME]+ [--hide title|description|url|owner|cost|trust|progress]+ See documentation on how to write project plan files++Available options:+ FILENAME plan file to read from (default from stdin)+ -o,--output FILENAME output file name (.png, .tif, .bmp, .jpg and .pdf+ supported)+ --progress-below N only display projects which progress is < N%+ -c,--color color each project by progress+ -w,--width NUMBER width of the output image+ --height NUMBER height of the output image+ -r,--root NAME name of the root project definition (default: "root")+ --hide title|description|url|owner|cost|trust|progress+ hide a particular property+ -h,--help Show this help text+```++### Syntax++Comments are C/C++/Java style: line comments start with `//`, and block comments+are in between `/*` and `*/`.++Everything else are definitions, in the form `name [attributes] [expression] ;`.++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+are three operators:++ * `p = a + b` - Sum: `p` is executed when `a` or `b` is executed.+ * `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.++Please note that a equal sign (`=`) can be placed optionally just before the+definition of the expression.++#### Attributes++Following is a list of supported attributes of projects:++| Property name | Expected Type | Description |+|---------------|---------------|-------------|+| title | text | title of the project |+| 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 (default 0%) |+| cost | number | estimated cost (default 0) |+| trust | percentage | probability of success (default 100%) |++Attributes can be specified between brackets, like, _e.g._:++```+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"+};+```
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
app/Main.hs view
@@ -20,7 +20,8 @@ import MasterPlan.Data import qualified MasterPlan.Parser as P import Options.Applicative-import System.IO (hPutStr, stderr, stdin)+import System.Exit (die)+import System.IO (stdin) -- |Type output from the command line parser data Opts = Opts { inputPath :: Maybe FilePath@@ -64,25 +65,25 @@ <> help "height of the output image" <> value (-1) <> metavar "NUMBER")- <*> strOption ( long "root"- <> short 'r'- <> help "name of the root project definition"- <> value "root"- <> showDefault- <> metavar "NAME")+ <*> (ProjectKey <$> strOption ( long "root"+ <> short 'r'+ <> help "name of the root project definition"+ <> value "root"+ <> showDefault+ <> metavar "NAME")) <*> (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- filterParser = (ProjFilter . mkProgressFilter) <$> option auto ( long "progress-below"- <> help "only display projects which progress is < N%"- <> metavar "N" )+ filterParser = (ProjFilter . mkProgressFilter . Progress) <$> option auto ( long "progress-below"+ <> help "only display projects which progress is < N%"+ <> metavar "N" ) where mkProgressFilter n sys p = progress sys p * 100 < n @@ -100,7 +101,7 @@ filterProj p@(Sum ps) = filterHelper p ps Sum filterProj p@(Product ps) = filterHelper p ps Product filterProj p@(Sequence ps) = filterHelper p ps Sequence- filterProj p = if f sys p then Just p else Nothing+ filterProj p = if f sys p then Just p else Nothing filterHelper p ps c = if f sys p then c <$> filterProjs ps else Nothing filterProjs ps = NE.nonEmpty (catMaybes $ NE.toList $ filterProj <$> ps)@@ -111,7 +112,7 @@ masterPlan opts = do contents <- maybe (TIO.hGetContents stdin) TIO.readFile $ inputPath opts case P.runParser (fromMaybe "stdin" $ inputPath opts) contents of- Left e -> hPutStr stderr e+ Left e -> die e Right sys@(ProjectSystem b) -> do let sys' = prioritizeSys $ ProjectSystem $ M.mapMaybe (filterBinding sys $ projFilter opts) b
master-plan.cabal view
@@ -1,81 +1,81 @@-name: master-plan -version: 0.1.0.0 -synopsis: The project management tool for hackers -description: Master Plan is a tool that parses files that describes - projects using a simple and powerful syntax in which - project structures are encoded using a special algebra - with combinators for specifying the different kinds - of dependencies. It also supports estimations of cost and - risk, as well as some metadata. The tool is then able - to compute the priority of execution that minimizes costs, - and also output a nice visual representation of the structure. - Becase the plan description is plan text, it's portable - and fits well within source control. -homepage: https://github.com/rodrigosetti/master-plan -bug-reports: https://github.com/rodrigosetti/master-plan/issues -author: Rodrigo Setti -maintainer: rodrigosetti@gmail.com -stability: alpha -license: MIT -license-file: LICENSE -copyright: 2017 Rodrigo Setti. All rights reserved -category: Tools -build-type: Simple -cabal-version: >=1.10 -extra-source-files: README.md - -source-repository head - type: git - location: git://github.com/rodrigosetti/master-plan.git - -executable master-plan - hs-source-dirs: app - main-is: Main.hs - default-language: Haskell2010 - ghc-options: -Wall - default-extensions: UnicodeSyntax - build-depends: base >= 4.5 && < 5 - , containers - , master-plan - , optparse-applicative - , text - -library - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall - default-extensions: UnicodeSyntax - build-depends: base >= 4.5 && < 5 - , containers - , diagrams - , diagrams-lib - , diagrams-rasterific - , megaparsec - , mtl - , text - , syb - exposed-modules: MasterPlan.Data - , MasterPlan.Parser - , MasterPlan.Backend.Graph - , MasterPlan.Backend.Identity - , MasterPlan.Internal.Debug - -test-suite spec - type: exitcode-stdio-1.0 - main-is: Spec.hs - hs-source-dirs: test - ghc-options: -Wall - default-language: Haskell2010 - build-depends: base >= 4.5 && < 5 - , QuickCheck - , containers - , hspec - , master-plan - , mtl - , quickcheck-instances - , random - , random-shuffle - , text - other-modules: MasterPlan.DataSpec - , MasterPlan.Arbitrary - , MasterPlan.ParserSpec +name: master-plan+version: 0.2.0.0+synopsis: The project management tool for hackers+description: Master Plan is a tool that parses files that describes+ projects using a simple and powerful syntax in which+ project structures are encoded using a special algebra+ with combinators for specifying the different kinds+ of dependencies. It also supports estimations of cost and+ risk, as well as some metadata. The tool is then able+ to compute the priority of execution that minimizes costs,+ and also output a nice visual representation of the structure.+ Becase the plan description is plan text, it's portable+ and fits well within source control.+homepage: https://github.com/rodrigosetti/master-plan+bug-reports: https://github.com/rodrigosetti/master-plan/issues+author: Rodrigo Setti+maintainer: rodrigosetti@gmail.com+stability: alpha+license: MIT+license-file: LICENSE+copyright: 2017 Rodrigo Setti. All rights reserved+category: Tools+build-type: Simple+cabal-version: >=1.10+extra-source-files: README.md++source-repository head+ type: git+ location: git://github.com/rodrigosetti/master-plan.git++executable master-plan+ hs-source-dirs: app+ main-is: Main.hs+ default-language: Haskell2010+ ghc-options: -Wall+ default-extensions: UnicodeSyntax+ build-depends: base >= 4.5 && < 5+ , containers+ , master-plan+ , optparse-applicative+ , text++library+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall+ default-extensions: UnicodeSyntax+ build-depends: base >= 4.5 && < 5+ , containers+ , diagrams+ , diagrams-lib+ , diagrams-rasterific+ , megaparsec+ , mtl+ , text+ , syb+ exposed-modules: MasterPlan.Data+ , MasterPlan.Parser+ , MasterPlan.Backend.Graph+ , MasterPlan.Backend.Identity+ , MasterPlan.Internal.Debug++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test+ ghc-options: -Wall+ default-language: Haskell2010+ build-depends: base >= 4.5 && < 5+ , QuickCheck+ , containers+ , hspec+ , master-plan+ , mtl+ , quickcheck-instances+ , random+ , random-shuffle+ , text+ other-modules: MasterPlan.DataSpec+ , MasterPlan.Arbitrary+ , MasterPlan.ParserSpec
src/MasterPlan/Backend/Graph.hs view
@@ -1,200 +1,236 @@-{-| -Module : MasterPlan.Backend.Graph -Description : a backend that renders to PNG diagram -Copyright : (c) Rodrigo Setti, 2017 -License : MIT -Maintainer : rodrigosetti@gmail.com -Stability : experimental -Portability : POSIX --} -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TupleSections #-} -module MasterPlan.Backend.Graph (render, RenderOptions(..)) where - -import MasterPlan.Data -import Diagrams.Prelude hiding (render, Product, Sum) -import Diagrams.Backend.Rasterific -import Data.List (intersperse) -import Control.Applicative ((<|>)) -import Control.Monad.State -import qualified Data.Map as M -import Data.Tree -import Data.Maybe (fromMaybe, catMaybes) -import qualified Data.List.NonEmpty as NE -import Text.Printf (printf) -import Diagrams.TwoD.Text (Text) - --- text :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any --- text = texterific - -leftText :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any -leftText = alignedText 0 0.5 - -rightText :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any -rightText = alignedText 1 0.5 - --- * Types - -data NodeType = SumNode | ProductNode | SequenceNode | AtomicNode - --- |Data type used by the tree -data PNode = PNode (Maybe ProjectKey) - (Maybe ProjectProperties) - Cost - Trust - Progress - | NodeRef ProjectKey - -type RenderModel = Tree (NodeType, PNode) - -mkLeaf :: PNode -> RenderModel -mkLeaf a = Node (AtomicNode, a) [] - --- |Translates a ProjectSystem into a Tree PNode -toRenderModel :: ProjectSystem -> ProjectKey -> State [ProjectKey] (Maybe RenderModel) -toRenderModel sys rootK = case M.lookup rootK (bindings sys) of - Nothing -> pure Nothing - Just b -> Just <$> bindingToRM rootK b - where - bindingToRM :: ProjectKey -> Binding -> State [ProjectKey] RenderModel - bindingToRM key (BindingExpr prop p) = projToRM p (Just key) (Just prop) - 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 - -> NE.NonEmpty ProjectExpr - -> Maybe ProjectKey - -> Maybe ProjectProperties - -> State [ProjectKey] RenderModel - mkNode f p ps key prop = f (PNode key prop - (cost sys p) - (trust sys p) - (progress sys p)) - <$> mapM (\p' -> projToRM p' Nothing Nothing) (NE.toList ps) - - projToRM :: ProjectExpr -> Maybe ProjectKey -> Maybe ProjectProperties -> State [ProjectKey] RenderModel - projToRM p@(Sum ps) = mkNode (\x -> Node (SumNode, x)) p ps - projToRM p@(Sequence ps) = mkNode (\x -> Node (SequenceNode, x)) p ps - projToRM p@(Product ps) = mkNode (\x -> Node (ProductNode, x)) p ps - projToRM (Reference n) = - \k p -> case M.lookup n $ bindings sys of - Nothing -> pure $ Node (AtomicNode, PNode k (p <|> pure defaultProjectProps {title=n}) defaultCost defaultTrust defaultProgress) [] - Just b -> do alreadyProcessed <- gets (n `elem`) - if alreadyProcessed - then pure $ Node (AtomicNode, NodeRef $ bindingTitle b) [] - else modify (n:) >> bindingToRM n b - --- |how many children -treeSize :: Tree a -> Double -treeSize (Node _ []) = 1 -treeSize (Node _ ts) = sum $ treeSize <$> ts - --- |Options for rendering -data RenderOptions = RenderOptions { colorByProgress :: Bool -- ^Whether to color boxes depending on progress - , 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 - } deriving (Eq, Show) - --- | The main rendering function -render ∷ FilePath -> RenderOptions-> ProjectSystem → IO () -render fp (RenderOptions colorByP w h rootK props) sys = - let noRootEroor = text $ "no project named \"" ++ rootK ++ "\" found." - 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 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)) - ||| (translateX 2 typeSymbol # withEnvelope (mempty :: D V2 Double) <> hrule 4 # lwO 2) - ||| centerY (headBar === treeBar sizes) - ||| centerY (vcat $ map renderSubTree ts) - where - sizes = map ((* 6) . treeSize) ts - renderSubTree subtree = hrule 4 # lwO 2 ||| renderTree colorByP props subtree - - headBar = strutY $ treeSize t * 6 - - treeBar :: [Double] -> QDiagram B V2 Double Any - treeBar (s1:s2:ss) = vrule s1 # lwO 2 === vrule s2 # lwO 2 === treeBar (s2:ss) - treeBar [s1] = strutY s1 - treeBar _ = mempty - - typeSymbol = - let txt = case ty of - SumNode -> text "+" - ProductNode -> text "x" - SequenceNode -> text "->" - AtomicNode -> mempty - in txt # fontSizeL 2 # bold <> circle 2 # fc white # lwO 1 - -renderNode :: Bool -> [ProjProperty] -> 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) = - centerY nodeDia # withEnvelope (rect 30 12 :: D V2 Double) - where - nodeDia = - let hSizeAndSections = catMaybes [ (,2) <$> headerSection - , (,6) <$> descriptionSection - , (,2) <$> urlSection - , (,2) <$> bottomSection] - sections = map (\s -> strutY (snd s) <> fst s) hSizeAndSections - outerRect = rect 30 (sum $ map snd hSizeAndSections) # lwO 2 - 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 pro x = if pro `elem` props then x else Nothing - - headerSection = case [progressHeader, titleHeader, costHeader] of - [Nothing, Nothing, Nothing] -> Nothing - l -> Just $ strutX 30 <> mconcat (catMaybes l) - progressHeader = givenProp PProgress $ Just $ displayProgress p # translateX (-14) - titleHeader = givenProp PTitle $ (bold . text . title) <$> prop - 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 - - bottomSection = case [trustSubSection, ownerSubSection] of - [Nothing, Nothing] -> Nothing - l -> Just $ strutX 30 <> mconcat (catMaybes l) - - ownerSubSection = prop >>= owner >>= (pure . translateX 14 . rightText) - trustSubSection = translateX (-14) <$> - case t of - _ | PTrust `notElem` props -> Nothing - t' | t' == 1 -> Nothing - t' | t' == 0 -> Just $ leftText "impossible" - _ -> Just $ leftText ("trust = " ++ percentageText t) - - displayCost c' - | c' == 0 = mempty - | otherwise = rightText $ "(" ++ printf "%.1f" c' ++ ")" - displayProgress p' - | p' == 0 = mempty - | p' == 1 = leftText "done" - | otherwise = leftText $ percentageText p' - - -- color is red if the project hasn't started, green if it's done, or yellow - -- otherwise (i.e. in progress) - fcColor = - fc $ if colorByP then - (if p == 0 then pink else if p == 1 then lightgreen else lightyellow) - else white - - percentageText pct = show ((round $ pct * 100) :: Integer) ++ "%" +{-|+Module : MasterPlan.Backend.Graph+Description : a backend that renders to PNG diagram+Copyright : (c) Rodrigo Setti, 2017+License : MIT+Maintainer : rodrigosetti@gmail.com+Stability : experimental+Portability : POSIX+-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnicodeSyntax #-}+module MasterPlan.Backend.Graph (render, RenderOptions(..)) where++import Control.Applicative ((<|>))+import Control.Monad.State+import Data.List (intersperse, isSuffixOf)+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as M+import Data.Maybe+import Data.Tree+import Diagrams.Backend.Rasterific+import Diagrams.Prelude hiding (Product, Sum, render)+import Diagrams.TwoD.Text+import MasterPlan.Data+import Text.Printf (printf)++-- text :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any+-- text = texterific++leftText :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any+leftText = alignedText 0 0.5++rightText :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any+rightText = alignedText 1 0.5++-- |Render text with possible overflow by breaking lines and truncating with ...+textOverflow' :: (TypeableFloat n, Renderable (Text n) b)+ => FontSlant+ -> FontWeight+ -> Int -- ^maximum number of lines to break+ -> Int -- ^maximum number of chars per line+ -> n -- ^line spacing+ -> String -- ^the text+ -> QDiagram b V2 n Any+textOverflow' fs fw maxLines maxLineSize lineSpace txt =+ vsep lineSpace $ map (texterific' fs fw) ss+ where+ ss = reverse $ foldl processWord [] $ words txt+ processWord (l:ls) w+ | length (l ++ w) > maxLineSize = if length ls >= maxLines+ then (if "..." `isSuffixOf` l then l:ls else (l ++ " ..."):ls)+ else w:l:ls+ | otherwise = (l ++ " " ++ w):ls+ processWord [] w = [w]++-- |Render text with possible overflow by breaking lines and truncating with ...+textOverflow :: (TypeableFloat n, Renderable (Text n) b)+ => Int -- ^maximum number of lines to break+ -> Int -- ^maximum number of chars per line+ -> n -- ^line spacing+ -> String -- ^the text+ -> QDiagram b V2 n Any+textOverflow = textOverflow' FontSlantNormal FontWeightNormal++-- * Types++data NodeType = SumNode | ProductNode | SequenceNode | AtomicNode++-- |Data type used by the tree+data PNode = PNode (Maybe ProjectKey)+ (Maybe ProjectProperties)+ Cost+ Trust+ Progress+ | NodeRef ProjectKey++type RenderModel = Tree (NodeType, PNode)++mkLeaf :: PNode -> RenderModel+mkLeaf a = Node (AtomicNode, a) []++-- |Translates a ProjectSystem into a Tree PNode+toRenderModel :: ProjectSystem -> ProjectKey -> State [ProjectKey] (Maybe RenderModel)+toRenderModel sys rootK = case M.lookup rootK (bindings sys) of+ Nothing -> pure Nothing+ Just b -> Just <$> bindingToRM rootK b+ where+ bindingToRM :: ProjectKey -> Binding -> State [ProjectKey] RenderModel+ bindingToRM key (BindingExpr prop p) = projToRM p (Just key) (Just prop)+ bindingToRM key (BindingAtomic prop c t p) = pure $ mkLeaf $ PNode (Just key)+ (Just prop)+ c t p++ mkNode :: (PNode -> [RenderModel] -> RenderModel)+ -> ProjectExpr+ -> NE.NonEmpty ProjectExpr+ -> Maybe ProjectKey+ -> Maybe ProjectProperties+ -> State [ProjectKey] RenderModel+ mkNode f p ps key prop = f (PNode key prop+ (cost sys p)+ (trust sys p)+ (progress sys p))+ <$> mapM (\p' -> projToRM p' Nothing Nothing) (NE.toList ps)++ projToRM :: ProjectExpr -> Maybe ProjectKey -> Maybe ProjectProperties -> State [ProjectKey] RenderModel+ projToRM p@(Sum ps) = mkNode (\x -> Node (SumNode, x)) p ps+ projToRM p@(Sequence ps) = mkNode (\x -> Node (SequenceNode, x)) p ps+ projToRM p@(Product ps) = mkNode (\x -> Node (ProductNode, x)) p ps+ projToRM (Reference n) =+ \k p -> case M.lookup n $ bindings sys of+ Nothing -> pure $ Node (AtomicNode, PNode k (p <|> pure defaultProjectProps {title=getProjectKey n}) defaultCost defaultTrust defaultProgress) []+ Just b -> do alreadyProcessed <- gets (n `elem`)+ if alreadyProcessed+ then pure $ Node (AtomicNode, NodeRef $ ProjectKey $ bindingTitle b) []+ else modify (n:) >> bindingToRM n b++-- |how many leaf nodes+leafCount :: Tree a -> Double+leafCount (Node _ []) = 1+leafCount (Node _ ts) = sum $ leafCount <$> ts++-- |Options for rendering+data RenderOptions = RenderOptions { colorByProgress :: Bool -- ^Whether to color boxes depending on progress+ , 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 :: [ProjAttribute] -- ^Properties that should be rendered+ } deriving (Eq, Show)++-- | The main rendering function+render ∷ FilePath -> RenderOptions-> ProjectSystem → IO ()+render fp (RenderOptions colorByP w h rootK props) sys =+ let noRootEroor = texterific $ "no project named \"" ++ getProjectKey rootK ++ "\" found."+ 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 -> [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 * leafCount x) <> alignL (centerY $ renderNode colorByP props n))+ ||| (translateX 2 typeSymbol # withEnvelope (mempty :: D V2 Double) <> hrule 4 # lwO 2)+ ||| centerY (headBar === treeBar sizes)+ ||| centerY (vcat $ map renderSubTree ts)+ where+ sizes = map ((* 6) . leafCount) ts+ renderSubTree subtree = hrule 4 # lwO 2 ||| renderTree colorByP props subtree++ headBar = strutY $ leafCount t * 6++ treeBar :: [Double] -> QDiagram B V2 Double Any+ treeBar (s1:s2:ss) = vrule s1 # lwO 2 === vrule s2 # lwO 2 === treeBar (s2:ss)+ treeBar [s1] = strutY s1+ treeBar _ = mempty++ typeSymbol =+ let txt = case ty of+ SumNode -> text "+"+ ProductNode -> text "x"+ SequenceNode -> text "->"+ AtomicNode -> mempty+ in txt # fontSizeL 2 # bold <> roundedRect 3 2 1 # fc white # lwO 1++renderNode :: Bool -> [ProjAttribute] -> PNode -> QDiagram B V2 Double Any+renderNode _ _ (NodeRef (ProjectKey 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) =+ centerY nodeDia <> strutY 12+ where+ nodeDia =+ let sections = if isJust titleHeader+ then catMaybes [ headerSection+ , descriptionSection+ , urlSection+ , bottomSection]+ else maybeToList simplifiedNode+ sectionsWithSep = vcat (intersperse (hrule nodeW # dashingN [0.005, 0.005] 0 # lwO 1) sections)+ in centerY (sectionsWithSep <> boundingRect sectionsWithSep # fc projColor # lwO 2)++ nodeW = 30++ simplifiedNode = case [progressHeader, trustHeader' text, costHeader] of+ [Nothing, Nothing, Nothing] -> Nothing+ l -> Just $ strutY 2 <> strutX nodeW <> mconcat (catMaybes l)++ givenProp :: ProjAttribute -> Maybe a -> Maybe a+ givenProp pro x = if pro `elem` props then x else Nothing++ headerSection = case [progressHeader, titleHeader, costHeader] of+ [Nothing, Nothing, Nothing] -> Nothing+ l -> Just $ strutY 2 <> strutX nodeW <> mconcat (catMaybes l)+ progressHeader = givenProp PProgress $ Just $ displayProgress p # translateX (-nodeW/2 + 1)+ titleHeader = givenProp PTitle $+ (centerXY . textOverflow' FontSlantNormal FontWeightBold 1 30 0.1 . title) <$> prop+ costHeader = givenProp PCost $ Just $ displayCost c # translateX (nodeW/2 - 1)++ descriptionSection, urlSection, bottomSection :: Maybe (QDiagram B V2 Double Any)+ descriptionSection = givenProp PDescription $ prop+ >>= description+ >>= (pure . centerX . frame 0.3 . textOverflow 3 40 0.1)+ urlSection = givenProp PUrl $ prop+ >>= url+ >>= (pure . centerX . frame 0.3 . textOverflow 1 20 0)++ bottomSection = case [trustHeader, ownerHeader] of+ [Nothing, Nothing] -> Nothing+ l -> Just $ strutY 2 <> strutX nodeW <> mconcat (catMaybes l)++ ownerHeader = prop >>= owner >>= (pure . translateX (nodeW/2 -1) . rightText)+ trustHeader = translateX (-nodeW/2+1) <$> trustHeader' leftText++ trustHeader' txt = case t of+ _ | PTrust `notElem` props -> Nothing+ t' | t' == defaultTrust -> Nothing+ t' | t' == 0 -> Just $ txt "impossible"+ _ -> Just $ txt ("trust = " ++ percentageText (getTrust t))++ displayCost c'+ | c' == defaultCost = mempty+ | otherwise = rightText $ "(" ++ printf "%.1f" (getCost c') ++ ")"+ displayProgress p'+ | p' == defaultProgress = mempty+ | p' == 1 = leftText "done"+ | otherwise = leftText $ percentageText $ getProgress p'++ -- color is red if the project hasn't started, green if it's done, or yellow+ -- otherwise (i.e. in progress)+ projColor =+ if colorByP then+ (if p == 0 then pink else if p == 1 then lightgreen else lightyellow)+ else white++ percentageText pct = printf "%.1f%%" (pct * 100)
src/MasterPlan/Backend/Identity.hs view
@@ -1,92 +1,92 @@-{-| -Module : MasterPlan.Backend.Identity -Description : a backend that renders to a text that can be parsed -Copyright : (c) Rodrigo Setti, 2017 -License : MIT -Maintainer : rodrigosetti@gmail.com -Stability : experimental -Portability : POSIX --} -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE OverloadedStrings #-} -module MasterPlan.Backend.Identity (render) where - -import Control.Monad (when, void) -import Control.Monad.RWS (RWS, evalRWS, gets, tell, modify, asks) -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 MasterPlan.Data - --- |Plain text renderer -render ∷ ProjectSystem → [ProjProperty] -> 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" - -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 - modify $ M.delete projName - mapM_ renderName $ dependencies b - -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 +{-|+Module : MasterPlan.Backend.Identity+Description : a backend that renders to a text that can be parsed+Copyright : (c) Rodrigo Setti, 2017+License : MIT+Maintainer : rodrigosetti@gmail.com+Stability : experimental+Portability : POSIX+-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UnicodeSyntax #-}+module MasterPlan.Backend.Identity (render) where++import Control.Monad (when)+import Control.Monad.RWS (RWS, evalRWS, gets, modify, tell)+import Data.Generics+import Data.List (nub)+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as M+import Data.Maybe (isJust)+import Data.Monoid ((<>))+import qualified Data.Text as T+import MasterPlan.Data++-- |Plain text renderer+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 [ProjAttribute] T.Text (M.Map ProjectKey Binding)++renderName ∷ ProjectKey → RenderMonad ()+renderName projName =+ do mb <- gets $ M.lookup projName+ case mb of+ Nothing -> pure ()+ Just b -> do tell $ T.pack $ getProjectKey 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 /= getProjectKey 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 $ getCost c) <> "\n"+ when (t /= defaultTrust) $ tell $ "trust " <> percentage (getTrust t) <> "\n"+ when (p /= defaultProgress) $ tell $ "progress " <> percentage (getProgress 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 /= getProjectKey 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 (ProjectKey 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 _ = []
src/MasterPlan/Data.hs view
@@ -7,18 +7,20 @@ Stability : experimental Portability : POSIX -}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UnicodeSyntax #-} module MasterPlan.Data ( ProjectExpr(..) , ProjectProperties(..) , ProjectSystem(..) , Binding(..)- , ProjectKey- , ProjProperty(..)- , Trust- , Cost- , Progress+ , ProjectKey(..)+ , ProjAttribute(..)+ , Trust(..)+ , Cost(..)+ , Progress(..) , defaultProjectProps , defaultCost , defaultTrust@@ -37,14 +39,20 @@ import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE import qualified Data.Map as M+import Data.String (IsString) -- * Types -type Trust = Float-type Cost = Float-type Progress = Float-type ProjectKey = String+newtype Trust = Trust { getTrust :: Float }+ deriving (Show, Eq, Data, Typeable, Ord, Num, Real, RealFrac, Fractional)+newtype Cost = Cost { getCost :: Float }+ deriving (Show, Eq, Data, Typeable, Ord, Num, Real, RealFrac, Fractional)+newtype Progress = Progress { getProgress :: Float }+ deriving (Show, Eq, Data, Typeable, Ord, Num, Real, RealFrac, Fractional) +newtype ProjectKey = ProjectKey { getProjectKey :: String }+ deriving (Show, Eq, Data, Typeable, Ord, IsString)+ -- |Structure of a project expression data ProjectExpr = Sum (NE.NonEmpty ProjectExpr) | Product (NE.NonEmpty ProjectExpr)@@ -57,7 +65,6 @@ -- 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 +74,10 @@ , 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,53 +112,49 @@ 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- Nothing -> defaultCost -- mentioned but no props neither task defined+ Just (BindingAtomic _ (Cost c) _ (Progress p)) -> Cost $ c * (1 - p) -- cost is weighted by remaining progress+ 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 cost sys (Sum ps) =- sum $ map (\x -> (1 - snd x) * fst x) $ zip costs accTrusts+ Cost $ sum $ map (\x -> (1 - snd x) * fst x) $ zip costs accTrusts where- accTrusts = NE.toList $ NE.scanl (\a b -> a + b*(1-a)) 0 $ trust sys <$> ps- costs = NE.toList $ cost sys <$> ps+ costs = NE.toList $ (getCost . cost sys) <$> ps+ accTrusts = NE.toList $ NE.scanl (\a b -> a + b*(1-a)) 0 $ (getTrust . trust sys) <$> ps costConjunction ∷ ProjectSystem → NE.NonEmpty ProjectExpr → Cost costConjunction sys ps =- sum $ zipWith (*) costs accTrusts+ Cost $ sum $ zipWith (*) costs accTrusts where- costs = NE.toList $ cost sys <$> ps- accTrusts = NE.toList $ product <$> NE.inits (trust sys <$> ps)+ costs = NE.toList $ (getCost . cost sys) <$> ps+ accTrusts = NE.toList $ product <$> NE.inits ((getTrust . trust sys) <$> ps) -- | Expected probability of succeeding 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- Nothing -> defaultTrust -- mentioned but no props neither task defined+ Just (BindingAtomic _ _ (Trust t) (Progress p)) -> Trust $ p + t * (1-p)+ 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 trust sys (Sum ps) =- foldl (\a b -> a + b*(1-a)) 0 $ trust sys <$> ps+ Trust $ foldl (\a b -> a + b*(1-a)) 0 $ (getTrust . trust sys) <$> ps trustConjunction ∷ ProjectSystem → NE.NonEmpty ProjectExpr → Trust-trustConjunction sys ps = product $ trust sys <$> ps+trustConjunction sys ps = Trust $ product $ (getTrust . trust sys) <$> ps 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@@ -195,12 +198,16 @@ -- |Sort project in order that minimizes cost prioritizeProj ∷ ProjectSystem → ProjectExpr → ProjectExpr prioritizeProj sys (Sum ps) =- let f p = cost sys p / trust sys p- in Sum $ NE.sortWith (nanToInf . f) $ prioritizeProj sys <$> ps+ let f p = getCost (cost sys' p) / getTrust (trust sys' p)+ sys' = prioritizeSys sys+ in Sum $ NE.sortWith (nanToInf . f) $ prioritizeProj sys' <$> ps prioritizeProj sys (Product ps) =- let f p = cost sys p / (1 - trust sys p)- in Product $ NE.sortWith (nanToInf . f) $ prioritizeProj sys <$> ps-prioritizeProj _ p = p+ let f p = getCost (cost sys' p) / (1 - getTrust (trust sys' p))+ sys' = prioritizeSys sys+ in Product $ NE.sortWith (nanToInf . f) $ prioritizeProj sys' <$> ps+prioritizeProj sys (Sequence ps) =+ Sequence $ prioritizeProj sys <$> ps+prioritizeProj _ p = p -- |Helper function to transform any Nan (not a number) to positive infinity nanToInf :: RealFloat a => a -> a
src/MasterPlan/Internal/Debug.hs view
@@ -22,11 +22,11 @@ debugSys sys@(ProjectSystem bs) = void $ M.traverseWithKey printBinding bs where printBinding key b = do putStrLn "-------------------"- putStr $ key ++ " = "+ putStr $ getProjectKey key ++ " = " 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 "?"+ BindingAtomic _ (Cost c) (Trust t) (Progress p) ->+ putStrLn $ printf "(c:%.2f,t:%.2f,p:%2.f)" c t p -- |Print a Project Expression in a Project System to standard output. -- The expression is printed in a tree like fashion.@@ -37,9 +37,12 @@ ident il = replicateM_ il $ putStr " |" print' ∷ Int → ProjectExpr → IO ()- print' il p@(Reference n) = ident il >> putStr ("-" ++ n ++ " ") >> ctp p+ print' il p@(Reference (ProjectKey n)) = ident il >> putStr ("-" ++ n ++ " ") >> ctp p print' il p@(Sum ps) = ident il >> putStr "-+ " >> ctp p >> forM_ ps (print' $ il+1) print' il p@(Sequence ps) = ident il >> putStr "-> " >> ctp p >> forM_ ps (print' $ il+1) print' il p@(Product ps) = ident il >> putStr "-* " >> ctp p >> forM_ ps (print' $ il+1) - ctp p = putStrLn $ printf " c=%.2f t=%.2f p=%.2f" (cost sys p) (trust sys p) (progress sys p)+ ctp p = putStrLn $ printf " c=%.2f t=%.2f p=%.2f"+ (getCost $ cost sys p)+ (getTrust $ trust sys p)+ (getProgress $ progress sys p)
src/MasterPlan/Parser.hs view
@@ -1,159 +1,167 @@-{-| -Module : MasterPlan.Parser -Description : export parser for project systems -Copyright : (c) Rodrigo Setti, 2017 -License : MIT -Maintainer : rodrigosetti@gmail.com -Stability : experimental -Portability : POSIX --} -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -module MasterPlan.Parser (runParser) where - -import Control.Monad.State -import Data.Generics -import Data.List (nub) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as M -import qualified Data.Text as T -import Data.Void -import MasterPlan.Data -import Text.Megaparsec hiding (State, runParser) -import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L -import Text.Megaparsec.Expr - -type Parser = ParsecT Void T.Text (State ProjectSystem) - --- |Space consumer -sc ∷ Parser () -sc = L.space space1 lineCmnt blockCmnt - where - lineCmnt = L.skipLineComment "//" - blockCmnt = L.skipBlockComment "/*" "*/" - -lexeme ∷ Parser a → Parser a -lexeme = L.lexeme sc - -symbol ∷ T.Text → Parser T.Text -symbol = L.symbol sc - --- | 'parens' parses something between parenthesis. -parens ∷ Parser a → Parser a -parens = between (symbol "(") (symbol ")") - --- |list of reserved words -rws ∷ [String] -rws = map show [minBound :: ProjProperty ..] - -identifier ∷ Parser String -identifier = (lexeme . try) (p >>= check) - where - p = (:) <$> letterChar <*> many alphaNumChar - check x - | x `elem` rws = fail $ "keyword " ++ show x ++ " cannot be an identifier" - | otherwise = pure x - -stringLiteral :: Parser String -stringLiteral = char '"' >> manyTill L.charLiteral (char '"') - -percentage :: Parser Float -percentage = do n <- L.float <?> "percentage value" - when (n > 100) $ fail $ "number " ++ show n ++ " is not within (0,100) range" - void $ symbol "%" - pure $ n / 100 - -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 = - simplifyProj <$> makeExprParser term table <?> "expression" - where - term = parens expressionParser <|> (Reference <$> identifier) - table = [[binary "*" (combineWith Product)] - ,[binary "->" (combineWith Sequence)] - ,[binary "+" (combineWith Sum)]] - binary op f = InfixL (f <$ symbol op) - - combineWith :: (NE.NonEmpty ProjectExpr -> ProjectExpr) -> ProjectExpr -> ProjectExpr -> ProjectExpr - combineWith c p1 p2 = c $ p1 NE.<| [p2] - -dependencies ∷ ProjectSystem -> ProjectExpr → [ProjectKey] -dependencies sys = everything (++) ([] `mkQ` collectDep) - where - collectDep (Reference n) = nub $ n : everything (++) ([] `mkQ` collectDep) (M.lookup n $ bindings sys) - collectDep _ = [] - -projectSystem :: Parser ProjectSystem -projectSystem = - do between sc eof definitionSeq - lift get - where - definitionSeq = void $ endBy1 definition (symbol ";") - - -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 +{-|+Module : MasterPlan.Parser+Description : export parser for project systems+Copyright : (c) Rodrigo Setti, 2017+License : MIT+Maintainer : rodrigosetti@gmail.com+Stability : experimental+Portability : POSIX+-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UnicodeSyntax #-}+module MasterPlan.Parser (runParser) where++import Control.Monad.State+import Data.Generics+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+import Text.Megaparsec hiding (State, runParser)+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L+import Text.Megaparsec.Expr++type Parser = Parsec Void T.Text++-- |Space consumer+sc ∷ Parser ()+sc = L.space space1 (L.skipLineComment "//") $+ L.skipBlockComment "/*" "*/"++lexeme ∷ Parser a → Parser a+lexeme = L.lexeme sc++symbol ∷ T.Text → Parser T.Text+symbol = L.symbol sc++-- | 'parens' parses something between parenthesis.+parens ∷ Parser a → Parser a+parens = between (symbol "(") (symbol ")")++-- |list of reserved words+rws ∷ [String]+rws = map show [minBound :: ProjAttribute ..]++identifier ∷ Parser String+identifier = (lexeme . try) $ (:) <$> letterChar <*> many alphaNumChar++projectKey :: Parser ProjectKey+projectKey = ProjectKey <$> (identifier >>= check) <?> "project key"+ where+ check x+ | x `elem` rws = fail $ "keyword " ++ show x ++ " cannot be an identifier"+ | otherwise = pure x++stringLiteral :: Parser String+stringLiteral = char '"' >> manyTill L.charLiteral (char '"')++percentage :: Parser Float+percentage = do n <- L.float <?> "percentage value"+ when (n > 100) $ fail $ "number " ++ show n ++ " is not within (0,100) range"+ void $ symbol "%"+ pure $ n / 100++nonNegativeNumber :: Parser Float+nonNegativeNumber = L.float++expression ∷ Parser ProjectExpr+expression =+ simplifyProj <$> makeExprParser term table <?> "expression"+ where+ term = parens expression <|> (Reference <$> projectKey)+ table = [[binary "*" (combineWith Product)]+ ,[binary "->" (combineWith Sequence)]+ ,[binary "+" (combineWith Sum)]]+ binary op f = InfixL (f <$ symbol op)++ combineWith :: (NE.NonEmpty ProjectExpr -> ProjectExpr) -> ProjectExpr -> ProjectExpr -> ProjectExpr+ combineWith c p1 p2 = c $ p1 NE.<| [p2]+++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=getProjectKey key}) Nothing Nothing Nothing++ noAttributes = pure (defaultProjectProps {title=getProjectKey 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 <- Cost <$> nonNegativeNumber <?> "cost"+ attributes props (Just c) mt mp+ PTrust -> do when (isJust mt) $ fail "redefinition of cost"+ t <- Trust <$> percentage <?> "trust"+ attributes props mc (Just t) mp+ PProgress -> do when (isJust mp) $ fail "redefinition of progress"+ p <- Progress <$> 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)+ collectDep _ = []++projectSystem :: Parser ProjectSystem+projectSystem =+ mkProjSystem <$> definitions []+ where+ mkProjSystem = ProjectSystem . M.fromList++ definitions ds = do key <- sc *> projectKey+ when (key `elem` map fst ds) $ fail $ "redefinition of \"" ++ getProjectKey key ++ "\""+ b <- binding key <* symbol ";"++ -- check if it's recursive+ let deps = dependencies (mkProjSystem ds) b+ when (key `elem` deps) $ fail $ "definition of \"" ++ getProjectKey key ++ "\" is recursive"++ let ds' = (key,b):ds+ (try eof *> pure ds') <|> definitions ds'++runParser :: FilePath -> T.Text -> Either String ProjectSystem+runParser filename contents = case parse projectSystem filename contents of+ Left e -> Left $ parseErrorPretty' contents e+ Right v -> Right v
test/MasterPlan/Arbitrary.hs view
@@ -1,67 +1,67 @@-{-# LANGUAGE UnicodeSyntax #-} -module MasterPlan.Arbitrary () where - -import Control.Monad (replicateM) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as M -import Data.Maybe (isNothing) -import MasterPlan.Data -import Test.QuickCheck -import Test.QuickCheck.Instances () - -instance Arbitrary ProjectProperties where - - arbitrary = - let s = getASCIIString <$> arbitrary - os = oneof [pure Nothing, Just <$> s] - in ProjectProperties <$> s <*> os <*> os <*> os - - shrink p = (if isNothing (description p) then [] else [p { description = Nothing }]) ++ - (if isNothing (url p) then [] else [p { url = Nothing }]) ++ - (if isNothing (owner p) then [] else [p { owner = Nothing }]) - -testingKeys ∷ [String] -testingKeys = ["a", "b", "c", "d"] - -instance Arbitrary ProjectSystem where - - arbitrary = do bs <- replicateM (length testingKeys) arbitrary - rootB <- BindingExpr <$> arbitrary <*> arbitrary - pure $ ProjectSystem $ M.insert "root" rootB $ M.fromList $ zip testingKeys bs - - shrink (ProjectSystem bs) = - map ProjectSystem $ concatMap shrinkOne testingKeys - where - shrinkOne ∷ String → [M.Map String Binding] - shrinkOne k = case M.lookup k bs of - Nothing -> [] - Just b -> map (\s -> M.adjust (const s) k bs) $ shrink b - -instance Arbitrary Binding where - - -- NOTE: Binding arbitrary are always tasks (no expression) - -- 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) ] - - shrink (BindingExpr pr e) = map (BindingExpr pr) $ shrink e - shrink _ = [] - -instance Arbitrary ProjectExpr where - - arbitrary = - let shrinkFactor n = 3 * n `quot` 5 - in frequency [ (1, Sum <$> scale shrinkFactor arbitrary) - , (1, Product <$> scale shrinkFactor arbitrary) - , (1, Sequence <$> scale shrinkFactor arbitrary) - , (2, Reference <$> elements testingKeys) ] - - shrink (Sum ps) = NE.toList ps - shrink (Product ps) = NE.toList ps - shrink (Sequence ps) = NE.toList ps - shrink (Reference _) = [] +{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UnicodeSyntax #-}+module MasterPlan.Arbitrary () where++import Control.Monad (replicateM)+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as M+import Data.Maybe (isNothing)+import MasterPlan.Data+import Test.QuickCheck+import Test.QuickCheck.Instances ()++instance Arbitrary ProjectProperties where++ arbitrary =+ let s = getASCIIString <$> arbitrary+ os = oneof [pure Nothing, Just <$> s]+ in ProjectProperties <$> s <*> os <*> os <*> os++ shrink p = (if isNothing (description p) then [] else [p { description = Nothing }]) +++ (if isNothing (url p) then [] else [p { url = Nothing }]) +++ (if isNothing (owner p) then [] else [p { owner = Nothing }])++testingKeys ∷ [ProjectKey]+testingKeys = ["a", "b", "c", "d"]++instance Arbitrary ProjectSystem where++ arbitrary = do bs <- replicateM (length testingKeys) arbitrary+ rootB <- BindingExpr <$> arbitrary <*> arbitrary+ pure $ ProjectSystem $ M.insert "root" rootB $ M.fromList $ zip testingKeys bs++ shrink (ProjectSystem bs) =+ map ProjectSystem $ concatMap shrinkOne testingKeys+ where+ shrinkOne ∷ ProjectKey → [M.Map ProjectKey Binding]+ shrinkOne k = case M.lookup k bs of+ Nothing -> []+ Just b -> map (\s -> M.adjust (const s) k bs) $ shrink b++instance Arbitrary Binding where++ -- NOTE: Binding arbitrary are always tasks (no expression)+ -- 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 BindingAtomic <$> arbitrary+ <*> (Cost <$> elements [0, 1 .. 100])+ <*> (Trust <$> unitGen)+ <*> (Progress <$> unitGen)++ shrink (BindingExpr pr e) = map (BindingExpr pr) $ shrink e+ shrink _ = []++instance Arbitrary ProjectExpr where++ arbitrary =+ let shrinkFactor n = 3 * n `quot` 5+ in frequency [ (1, Sum <$> scale shrinkFactor arbitrary)+ , (1, Product <$> scale shrinkFactor arbitrary)+ , (1, Sequence <$> scale shrinkFactor arbitrary)+ , (2, Reference <$> elements testingKeys) ]++ shrink (Sum ps) = NE.toList ps+ shrink (Product ps) = NE.toList ps+ shrink (Sequence ps) = NE.toList ps+ shrink (Reference _) = []
test/MasterPlan/DataSpec.hs view
@@ -1,145 +1,147 @@-{-# LANGUAGE UnicodeSyntax #-} -module MasterPlan.DataSpec (spec) where - -import Control.Monad.State -import Data.Bool (bool) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as M -import Data.Maybe (fromJust) -import MasterPlan.Arbitrary () -import MasterPlan.Data -import System.Random -import System.Random.Shuffle (shuffle') -import Test.Hspec -import Test.QuickCheck hiding (sample) -import Test.Hspec.QuickCheck (prop) - --- |Sample the simulation model of the execution of a project. --- It's a stateful computation with the random generator, which computes --- a 2-tuple with a Boolean: whether the execution was successful (A Bernoulli --- sample from trust), and the total actual cost incurred. -simulate ∷ RandomGen g ⇒ ProjectSystem → ProjectExpr → State g (Bool, Cost) -simulate sys (Reference n) = - case M.lookup n (bindings sys) of - Just (BindingAtomic _ c t p) -> - do r <- state $ randomR (0, 1) - let remainingProgress = 1 - p - 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) - Nothing -> pure (True, defaultCost) - -simulate sys (Sequence ps) = simulateConjunction sys $ NE.toList ps -simulate sys (Product ps) = simulateConjunction sys $ NE.toList ps -simulate sys (Sum ps) = - simulate' $ NE.toList ps - where - simulate' ∷ RandomGen g ⇒ [ProjectExpr] → State g (Bool, Cost) - simulate' [] = pure (False, 0) - simulate' (p:rest) = do (success, c) <- simulate sys p - if success then - pure (True, c) - else - do (success', c') <- simulate' rest - pure (success', c + c') - --- |Helper function that samples from a sequence of projects to be executed in --- order, and which all must be successful for the end result to be succesful. --- This is the case for sequences, and products (in a particular permutation). -simulateConjunction ∷ RandomGen g ⇒ ProjectSystem → [ProjectExpr] → State g (Bool, Cost) -simulateConjunction _ [] = pure (True, 0) -simulateConjunction sys (p:rest) = do (success, c) <- simulate sys p - if success then do - (success', c') <- simulateConjunction sys rest - pure (success', c + c') - else - pure (False, c) - --- |Compute a project's trust and cost via a Monte Carlo method of computing --- the average of a handful of samples. -monteCarloTrustAndCost ∷ RandomGen g ⇒ Int → ProjectSystem → ProjectExpr → State g (Trust, Cost) -monteCarloTrustAndCost n sys p = do results <- replicateM n $ simulate sys p - let trusts = map (bool 0 1 . fst) results - costs = map snd results - pure (sum trusts / fromIntegral n, - sum costs / fromIntegral n) - -aproximatelyEqual ∷ Float -> Float -> Float → Float -> Property -aproximatelyEqual alpha beta x y = - counterexample (show x ++ " /= " ++ show y) $ diff <= max relError beta - where - relError = alpha * max (abs x) (abs y) - diff = abs $ x - y - -spec ∷ Spec -spec = do - describe "trust and cost" $ do - - let g = mkStdGen 837183 - - let eq = aproximatelyEqual 0.05 0.05 - - prop "monte-carlo and analytical implementations should agree" $ do - let p = Reference "root" - monteCarloAndAnalyticalMustAgree ∷ ProjectSystem -> Property - monteCarloAndAnalyticalMustAgree sys = - counterexample "disagree on cost" (cost' `eq` cost sys p) .&&. - counterexample "disagree on trust" (trust' `eq` trust sys p) - where - (trust', cost') = evalState (monteCarloTrustAndCost 50000 sys p) g - monteCarloAndAnalyticalMustAgree - - describe "simplification" $ do - - let eq = aproximatelyEqual 0.005 0.005 - - prop "is irreductible" $ do - let simplificationIsIrreductible :: ProjectExpr -> Property - simplificationIsIrreductible p = - let p' = simplifyProj p - p'' = simplifyProj p' - in p /= p' ==> p' == p'' - simplificationIsIrreductible - - prop "is stable" $ do - let simplifyIsStable :: ProjectSystem -> Property - simplifyIsStable sys = - let sys' = simplify sys - p = Reference "root" - in cost sys p `eq` cost sys' p .&&. trust sys p `eq` trust sys' p - - simplifyIsStable - - describe "prioritization" $ do - - let shuffleProjs :: NE.NonEmpty ProjectExpr -> IO (NE.NonEmpty ProjectExpr) - shuffleProjs ps = do ps' <- NE.toList <$> mapM shuffleProj ps - g <- newStdGen - pure $ NE.fromList $ shuffle' ps' (length ps') g - - shuffleProj :: ProjectExpr -> IO ProjectExpr - shuffleProj (Sum ps) = Sum <$> shuffleProjs ps - shuffleProj (Product ps) = Product <$> shuffleProjs ps - shuffleProj p = pure p - - prop "minimize cost and keep trust stable" $ do - -- This test verifies that for any arbitrary project tree, the - -- prioritized version of it will have the minimum cost. - - let eq = aproximatelyEqual 0.005 0.005 - - let prioritizeMinimizesCost :: ProjectSystem -> Property - prioritizeMinimizesCost sys = - let (BindingExpr _ p) = fromJust $ M.lookup "root" $ bindings sys - op = prioritizeProj sys p - ocost = cost sys op - otrust = trust sys op - costIsLessOrEqual p' = - counterexample ("variation has smaller cost: " ++ show p') $ ocost <= cost sys p' - trustIsSame p' = otrust `eq` trust sys p' - in ioProperty $ do variations <- replicateM 10 (shuffleProj p) - return $ conjoin (map costIsLessOrEqual variations) .&. - conjoin (map trustIsSame variations) - prioritizeMinimizesCost +{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UnicodeSyntax #-}+module MasterPlan.DataSpec (spec) where++import Control.Monad.State+import Data.Bool (bool)+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as M+import Data.Maybe (fromJust)+import MasterPlan.Arbitrary ()+import MasterPlan.Data+import System.Random+import System.Random.Shuffle (shuffle')+import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck hiding (sample)++-- |Sample the simulation model of the execution of a project.+-- It's a stateful computation with the random generator, which computes+-- a 2-tuple with a Boolean: whether the execution was successful (A Bernoulli+-- sample from trust), and the total actual cost incurred.+simulate ∷ RandomGen g ⇒ ProjectSystem → ProjectExpr → State g (Bool, Cost)+simulate sys (Reference n) =+ case M.lookup n (bindings sys) of+ Just (BindingAtomic _ (Cost c) (Trust t) (Progress p)) ->+ do r <- state $ randomR (0, 1)+ let remainingProgress = 1 - p+ effectiveTrust = p + t * remainingProgress+ effectiveCost = c * remainingProgress+ pure (effectiveTrust > r, Cost effectiveCost)+ Just (BindingExpr _ p) -> simulate sys p -- TODO:30 avoid cyclic+ Nothing -> pure (True, defaultCost)++simulate sys (Sequence ps) = simulateConjunction sys $ NE.toList ps+simulate sys (Product ps) = simulateConjunction sys $ NE.toList ps+simulate sys (Sum ps) =+ simulate' $ NE.toList ps+ where+ simulate' ∷ RandomGen g ⇒ [ProjectExpr] → State g (Bool, Cost)+ simulate' [] = pure (False, 0)+ simulate' (p:rest) = do (success, c) <- simulate sys p+ if success then+ pure (True, c)+ else+ do (success', c') <- simulate' rest+ pure (success', c + c')++-- |Helper function that samples from a sequence of projects to be executed in+-- order, and which all must be successful for the end result to be succesful.+-- This is the case for sequences, and products (in a particular permutation).+simulateConjunction ∷ RandomGen g ⇒ ProjectSystem → [ProjectExpr] → State g (Bool, Cost)+simulateConjunction _ [] = pure (True, 0)+simulateConjunction sys (p:rest) = do (success, c) <- simulate sys p+ if success then do+ (success', c') <- simulateConjunction sys rest+ pure (success', c + c')+ else+ pure (False, c)++-- |Compute a project's trust and cost via a Monte Carlo method of computing+-- the average of a handful of samples.+monteCarloTrustAndCost ∷ RandomGen g ⇒ Int → ProjectSystem → ProjectExpr → State g (Trust, Cost)+monteCarloTrustAndCost n sys p = do results <- replicateM n $ simulate sys p+ let trusts = map (bool 0 1 . fst) results+ costs = map snd results+ pure (sum trusts / fromIntegral n,+ sum costs / fromIntegral n)++aproximatelyEqual ∷ (Show a, Real a, Fractional a) => a -> a -> a → a -> Property+aproximatelyEqual alpha beta x y =+ counterexample (show x ++ " /= " ++ show y) $ diff <= max relError beta+ where+ relError = alpha * max (abs x) (abs y)+ diff = abs $ x - y++spec ∷ Spec+spec = do+ describe "trust and cost" $ do++ let g = mkStdGen 837183++ let eq :: (Show a, Real a, Fractional a) => a -> a -> Property+ eq = aproximatelyEqual 0.05 0.05++ prop "monte-carlo and analytical implementations should agree" $ do+ let p = Reference "root"+ monteCarloAndAnalyticalMustAgree ∷ ProjectSystem -> Property+ monteCarloAndAnalyticalMustAgree sys =+ counterexample "disagree on cost" (cost' `eq` cost sys p) .&&.+ counterexample "disagree on trust" (trust' `eq` trust sys p)+ where+ (trust', cost') = evalState (monteCarloTrustAndCost 50000 sys p) g+ monteCarloAndAnalyticalMustAgree++ describe "simplification" $ do++ let eq :: (Show a, Real a, Fractional a) => a -> a -> Property+ eq = aproximatelyEqual 0.005 0.005++ prop "is irreductible" $ do+ let simplificationIsIrreductible :: ProjectExpr -> Property+ simplificationIsIrreductible p =+ let p' = simplifyProj p+ p'' = simplifyProj p'+ in p /= p' ==> p' == p''+ simplificationIsIrreductible++ prop "is stable" $ do+ let simplifyIsStable :: ProjectSystem -> Property+ simplifyIsStable sys =+ let sys' = simplify sys+ p = Reference "root"+ in cost sys p `eq` cost sys' p .&&. trust sys p `eq` trust sys' p++ simplifyIsStable++ describe "prioritization" $ do++ let shuffleProjs :: NE.NonEmpty ProjectExpr -> IO (NE.NonEmpty ProjectExpr)+ shuffleProjs ps = do ps' <- NE.toList <$> mapM shuffleProj ps+ g <- newStdGen+ pure $ NE.fromList $ shuffle' ps' (length ps') g++ shuffleProj :: ProjectExpr -> IO ProjectExpr+ shuffleProj (Sum ps) = Sum <$> shuffleProjs ps+ shuffleProj (Product ps) = Product <$> shuffleProjs ps+ shuffleProj p = pure p++ prop "minimize cost and keep trust stable" $ do+ -- This test verifies that for any arbitrary project tree, the+ -- prioritized version of it will have the minimum cost.++ let eq = aproximatelyEqual 0.005 0.005++ let prioritizeMinimizesCost :: ProjectSystem -> Property+ prioritizeMinimizesCost sys =+ let (BindingExpr _ p) = fromJust $ M.lookup "root" $ bindings sys+ op = prioritizeProj sys p+ ocost = cost sys op+ otrust = trust sys op+ costIsLessOrEqual p' =+ counterexample ("variation has smaller cost: " ++ show p') $ ocost <= cost sys p'+ trustIsSame p' = otrust `eq` trust sys p'+ in ioProperty $ do variations <- replicateM 10 (shuffleProj p)+ return $ conjoin (map costIsLessOrEqual variations) .&.+ conjoin (map trustIsSame variations)+ prioritizeMinimizesCost
test/MasterPlan/ParserSpec.hs view
@@ -3,6 +3,8 @@ module MasterPlan.ParserSpec (spec) where import Data.Either (isRight)+import qualified Data.Map as M+import Data.Maybe (fromJust) import Data.Monoid ((<>)) import qualified Data.Text as T import MasterPlan.Arbitrary ()@@ -17,7 +19,7 @@ spec = describe "parser" $ do - let allProps = [minBound :: ProjProperty ..]+ let allProps = [minBound :: ProjAttribute ..] prop "rendered should be parseable" $ do let renderedIsParseable ∷ ProjectSystem → Property@@ -36,6 +38,27 @@ in isRight parsed ==> parsed === Right sys' withMaxSuccess 50 propertyParseAndOutputIdentity++ it "should parse without prioritization" $ do++ let input = "root = a + b;\+ \a = x + y;\+ \b { cost 9 };\+ \x { cost 10 };\+ \y { cost 5 trust 90% };"++ let (Right sys) = runParser "test" input++ let (BindingExpr _ root) = fromJust $ M.lookup "root" (bindings sys)++ cost sys root `shouldBe` 10.0++ -- now prioritize... a little out of scope for this test, but fine:++ let sys' = prioritizeSys sys+ let (BindingExpr _ root') = fromJust $ M.lookup "root" (bindings sys')++ cost sys' root' `shouldBe` 6.0 it "should reject recursive equations" $ do
test/Spec.hs view
@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}