diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,123 +1,134 @@ -# master-plan - -[![Build Status](https://travis-ci.org/rodrigosetti/master-plan.svg?branch=master)](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 + +[![Build Status](https://travis-ci.org/rodrigosetti/master-plan.svg?branch=master)](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" +}; +``` diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/master-plan.cabal b/master-plan.cabal --- a/master-plan.cabal +++ b/master-plan.cabal @@ -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 diff --git a/src/MasterPlan/Backend/Graph.hs b/src/MasterPlan/Backend/Graph.hs --- a/src/MasterPlan/Backend/Graph.hs +++ b/src/MasterPlan/Backend/Graph.hs @@ -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) diff --git a/src/MasterPlan/Backend/Identity.hs b/src/MasterPlan/Backend/Identity.hs --- a/src/MasterPlan/Backend/Identity.hs +++ b/src/MasterPlan/Backend/Identity.hs @@ -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 _ = [] diff --git a/src/MasterPlan/Data.hs b/src/MasterPlan/Data.hs --- a/src/MasterPlan/Data.hs +++ b/src/MasterPlan/Data.hs @@ -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 diff --git a/src/MasterPlan/Internal/Debug.hs b/src/MasterPlan/Internal/Debug.hs --- a/src/MasterPlan/Internal/Debug.hs +++ b/src/MasterPlan/Internal/Debug.hs @@ -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) diff --git a/src/MasterPlan/Parser.hs b/src/MasterPlan/Parser.hs --- a/src/MasterPlan/Parser.hs +++ b/src/MasterPlan/Parser.hs @@ -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 diff --git a/test/MasterPlan/Arbitrary.hs b/test/MasterPlan/Arbitrary.hs --- a/test/MasterPlan/Arbitrary.hs +++ b/test/MasterPlan/Arbitrary.hs @@ -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 _) = [] diff --git a/test/MasterPlan/DataSpec.hs b/test/MasterPlan/DataSpec.hs --- a/test/MasterPlan/DataSpec.hs +++ b/test/MasterPlan/DataSpec.hs @@ -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 diff --git a/test/MasterPlan/ParserSpec.hs b/test/MasterPlan/ParserSpec.hs --- a/test/MasterPlan/ParserSpec.hs +++ b/test/MasterPlan/ParserSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,1 +1,1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}