master-plan (empty) → 0.1.0.0
raw patch · 14 files changed
+1332/−0 lines, 14 filesdep +QuickCheckdep +basedep +containerssetup-changed
Dependencies added: QuickCheck, base, containers, diagrams, diagrams-lib, diagrams-rasterific, hspec, master-plan, megaparsec, mtl, optparse-applicative, quickcheck-instances, random, random-shuffle, syb, text
Files
- LICENSE +21/−0
- README.md +123/−0
- Setup.hs +2/−0
- app/Main.hs +119/−0
- master-plan.cabal +81/−0
- src/MasterPlan/Backend/Graph.hs +200/−0
- src/MasterPlan/Backend/Identity.hs +92/−0
- src/MasterPlan/Data.hs +207/−0
- src/MasterPlan/Internal/Debug.hs +45/−0
- src/MasterPlan/Parser.hs +159/−0
- test/MasterPlan/Arbitrary.hs +67/−0
- test/MasterPlan/DataSpec.hs +145/−0
- test/MasterPlan/ParserSpec.hs +70/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +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.
+ README.md view
@@ -0,0 +1,123 @@+# 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 "%" +```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,119 @@+{-|+Module : Main+Description : Parses command line and dispatches to correct backend+Copyright : (c) Rodrigo Setti, 2017+License : MIT+Maintainer : rodrigosetti@gmail.com+Stability : experimental+Portability : POSIX+-}+{-# LANGUAGE UnicodeSyntax #-}+module Main (main) where++import Data.List (intercalate)+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as M+import Data.Maybe (catMaybes, fromMaybe)+import Data.Semigroup ((<>))+import qualified Data.Text.IO as TIO+import MasterPlan.Backend.Graph+import MasterPlan.Data+import qualified MasterPlan.Parser as P+import Options.Applicative+import System.IO (hPutStr, stderr, stdin)++-- |Type output from the command line parser+data Opts = Opts { inputPath :: Maybe FilePath+ , outputPath :: Maybe FilePath+ , projFilter :: ProjFilter -- ^ filter to consider+ , renderOptions :: RenderOptions }+ deriving (Show)++newtype ProjFilter = ProjFilter (ProjectSystem → ProjectExpr → Bool)++noFilter ∷ ProjFilter+noFilter = ProjFilter $ const $ const True++instance Show ProjFilter where+ show _ = "ProjFilter"++readEnum ∷ [(String, a)] → ReadM a+readEnum mapping = maybeReader $ flip lookup mapping++-- |The command line parser+cmdParser ∷ Parser Opts+cmdParser = Opts <$> optional (strArgument ( help "plan file to read from (default from stdin)"+ <> metavar "FILENAME" ))+ <*> optional (strOption ( long "output"+ <> short 'o'+ <> help "output file name (.png, .tif, .bmp, .jpg and .pdf supported)"+ <> metavar "FILENAME" ))+ <*> (filterParser <|> pure noFilter)+ <*> renderOptionsParser+ where+ renderOptionsParser ∷ Parser RenderOptions+ renderOptionsParser = RenderOptions <$> switch ( long "color"+ <> short 'c'+ <> help "color each project by progress")+ <*> option auto ( long "width"+ <> short 'w'+ <> help "width of the output image"+ <> value (-1)+ <> metavar "NUMBER")+ <*> option auto ( long "height"+ <> 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")+ <*> (invertProps <$> many (option property ( long "hide"+ <> help "hide a particular property"+ <> metavar (intercalate "|" $ map fst propertyNames))))+ propertyNames = map (\p -> (show p, p)) [minBound :: ProjProperty ..]+ property = readEnum propertyNames++ invertProps ∷ [ProjProperty] → [ProjProperty]+ 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" )+ where+ mkProgressFilter n sys p = progress sys p * 100 < n++main ∷ IO ()+main = masterPlan =<< execParser opts+ where+ opts = info (cmdParser <**> helper)+ ( fullDesc+ <> progDesc "See documentation on how to write project plan files"+ <> header "master-plan - project management tool for hackers" )++filterBinding ∷ ProjectSystem → ProjFilter → Binding → Maybe Binding+filterBinding sys (ProjFilter f) (BindingExpr r e) = BindingExpr r <$> filterProj e+ where+ 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++ filterHelper p ps c = if f sys p then c <$> filterProjs ps else Nothing+ filterProjs ps = NE.nonEmpty (catMaybes $ NE.toList $ filterProj <$> ps)++filterBinding _ _ b = Just b++masterPlan ∷ Opts → IO ()+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+ Right sys@(ProjectSystem b) ->+ do let sys' = prioritizeSys $ ProjectSystem $ M.mapMaybe+ (filterBinding sys $ projFilter opts) b+ let outfile = fromMaybe (fromMaybe "output" (outputPath opts) ++ ".pdf") $ outputPath opts+ render outfile (renderOptions opts) sys'
+ master-plan.cabal view
@@ -0,0 +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
+ src/MasterPlan/Backend/Graph.hs view
@@ -0,0 +1,200 @@+{-| +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) ++ "%"
+ src/MasterPlan/Backend/Identity.hs view
@@ -0,0 +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
+ src/MasterPlan/Data.hs view
@@ -0,0 +1,207 @@+{-|+Module : MasterPlan.Data+Description : Types for defining project and project systems+Copyright : (c) Rodrigo Setti, 2017+License : MIT+Maintainer : rodrigosetti@gmail.com+Stability : experimental+Portability : POSIX+-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE UnicodeSyntax #-}+module MasterPlan.Data ( ProjectExpr(..)+ , ProjectProperties(..)+ , ProjectSystem(..)+ , Binding(..)+ , ProjectKey+ , ProjProperty(..)+ , Trust+ , Cost+ , Progress+ , defaultProjectProps+ , defaultCost+ , defaultTrust+ , defaultProgress+ , defaultTaskProj+ , bindingTitle+ , cost+ , progress+ , trust+ , simplify+ , simplifyProj+ , prioritizeSys+ , prioritizeProj ) where++import Data.Generics+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as M++-- * Types++type Trust = Float+type Cost = Float+type Progress = Float+type ProjectKey = String++-- |Structure of a project expression+data ProjectExpr = Sum (NE.NonEmpty ProjectExpr)+ | Product (NE.NonEmpty ProjectExpr)+ | Sequence (NE.NonEmpty ProjectExpr)+ | Reference ProjectKey+ deriving (Eq, Show, Data, Typeable)++-- |A binding of a name can refer to an expression. If there are no+-- associated expressions (i.e. equation) then it can have task-level+-- 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+data ProjectProperties = ProjectProperties { title :: String+ , description :: Maybe String+ , url :: Maybe String+ , owner :: Maybe String+ } deriving (Eq, Show, Data, Typeable)++data ProjProperty = PTitle | PDescription | PUrl | POwner | PCost | PTrust | PProgress+ deriving (Eq, Enum, Bounded)++instance Show ProjProperty where+ show PTitle = "title"+ show PDescription = "description"+ show PUrl = "url"+ show POwner = "owner"+ show PCost = "cost"+ show PTrust = "trust"+ show PProgress = "progress"++-- |A project system defines the bindins (mapping from names to expressions or tasks)+-- and properties, which can be associated to any binding+newtype ProjectSystem = ProjectSystem { bindings :: M.Map ProjectKey Binding }+ deriving (Eq, Show, Data, Typeable)++defaultProjectProps ∷ ProjectProperties+defaultProjectProps = ProjectProperties { title = "?"+ , description = Nothing+ , url = Nothing+ , owner = Nothing }++defaultCost ∷ Cost+defaultCost = 0++defaultTrust ∷ Trust+defaultTrust = 1++defaultProgress ∷ Progress+defaultProgress = 0++defaultTaskProj ∷ ProjectProperties → Binding+defaultTaskProj pr = BindingAtomic pr defaultCost defaultTrust defaultProgress++bindingTitle ∷ Binding → String+bindingTitle (BindingAtomic ProjectProperties { title=t} _ _ _) = t+bindingTitle (BindingExpr ProjectProperties { title=t} _) = t+bindingTitle (BindingPlaceholder ProjectProperties { title=t}) = t++-- | Expected cost+cost ∷ ProjectSystem → ProjectExpr → Cost+cost sys (Reference n) =+ case M.lookup n (bindings sys) of+ Just (BindingAtomic _ c _ p) -> c * (1-p) -- cost is weighted by remaining progress+ Just (BindingExpr _ p) -> cost sys p -- TODO: avoid cyclic+ Just (BindingPlaceholder _) -> defaultCost -- mentioned but no props neither task defined+ 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+ where+ accTrusts = NE.toList $ NE.scanl (\a b -> a + b*(1-a)) 0 $ trust sys <$> ps+ costs = NE.toList $ cost sys <$> ps++costConjunction ∷ ProjectSystem → NE.NonEmpty ProjectExpr → Cost+costConjunction sys ps =+ sum $ zipWith (*) costs accTrusts+ where+ costs = NE.toList $ cost sys <$> ps+ accTrusts = NE.toList $ product <$> NE.inits (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+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++trustConjunction ∷ ProjectSystem → NE.NonEmpty ProjectExpr → Trust+trustConjunction sys ps = product $ 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+ Nothing -> defaultProgress -- mentioned but no props neither task defined+progress sys (Sequence ps) = progressConjunction sys ps+progress sys (Product ps) = progressConjunction sys ps+progress sys (Sum ps) = maximum $ progress sys <$> ps++progressConjunction ∷ ProjectSystem → NE.NonEmpty ProjectExpr → Progress+progressConjunction sys ps = sum (progress sys <$> ps) / fromIntegral (length ps)++-- |Simplify a project binding structure+simplify ∷ ProjectSystem → ProjectSystem+simplify = everywhere (mkT simplifyProj)++-- |Simplify a project expression structure+-- 1) transform singleton collections into it's only child+-- 2) flatten same constructor of the collection+simplifyProj ∷ ProjectExpr → ProjectExpr+simplifyProj (Sum (p :| [])) = simplifyProj p+simplifyProj (Product (p :| [])) = simplifyProj p+simplifyProj (Sequence (p :| [])) = simplifyProj p+simplifyProj (Sum ps) =+ Sum $ (reduce . simplifyProj) =<< ps+ where+ reduce (Sum ps') = reduce =<< ps'+ reduce p = [simplifyProj p]+simplifyProj (Product ps) =+ Product $ (reduce . simplifyProj) =<< ps+ where+ reduce (Product ps') = reduce =<< ps'+ reduce p = [simplifyProj p]+simplifyProj (Sequence ps) =+ Sequence $ (reduce . simplifyProj) =<< ps+ where+ reduce (Sequence ps') = reduce =<< ps'+ reduce p = [simplifyProj p]+simplifyProj p@Reference {} = p++-- |Sort projects in the system order that minimizes cost+prioritizeSys ∷ ProjectSystem → ProjectSystem+prioritizeSys sys = everywhere (mkT $ prioritizeProj sys) sys++-- |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+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++-- |Helper function to transform any Nan (not a number) to positive infinity+nanToInf :: RealFloat a => a -> a+nanToInf x = if isNaN x then 1/0 else x
+ src/MasterPlan/Internal/Debug.hs view
@@ -0,0 +1,45 @@+{-|+Module : MasterPlan.Internal.Debug+Description : Debugging functions+Copyright : (c) Rodrigo Setti, 2017+License : MIT+Maintainer : rodrigosetti@gmail.com+Stability : experimental+Portability : POSIX+-}+{-# LANGUAGE UnicodeSyntax #-}+module MasterPlan.Internal.Debug ( debugSys , debugProj) where++import Control.Monad (forM_, replicateM_, void)+import qualified Data.Map as M+import MasterPlan.Data+import Text.Printf (printf)++-- * Debugging++-- |Print a ProjectSystem to standard output+debugSys ∷ ProjectSystem → IO ()+debugSys sys@(ProjectSystem bs) = void $ M.traverseWithKey printBinding bs+ where+ printBinding key b = do putStrLn "-------------------"+ putStr $ 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 "?"++-- |Print a Project Expression in a Project System to standard output.+-- The expression is printed in a tree like fashion.+debugProj ∷ ProjectSystem → ProjectExpr → IO ()+debugProj sys = print' 0+ where+ ident ∷ Int → IO ()+ ident il = replicateM_ il $ putStr " |"++ print' ∷ Int → ProjectExpr → IO ()+ print' il p@(Reference 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)
+ src/MasterPlan/Parser.hs view
@@ -0,0 +1,159 @@+{-| +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
+ test/MasterPlan/Arbitrary.hs view
@@ -0,0 +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 _) = []
+ test/MasterPlan/DataSpec.hs view
@@ -0,0 +1,145 @@+{-# 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
+ test/MasterPlan/ParserSpec.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UnicodeSyntax #-}+module MasterPlan.ParserSpec (spec) where++import Data.Either (isRight)+import Data.Monoid ((<>))+import qualified Data.Text as T+import MasterPlan.Arbitrary ()+import MasterPlan.Backend.Identity (render)+import MasterPlan.Data+import MasterPlan.Parser (runParser)+import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck++spec ∷ Spec+spec =+ describe "parser" $ do++ let allProps = [minBound :: ProjProperty ..]++ prop "rendered should be parseable" $ do+ let renderedIsParseable ∷ ProjectSystem → Property+ renderedIsParseable sys =+ let rendered = render sys allProps+ in counterexample (T.unpack rendered) $ isRight (runParser "test1" rendered)++ withMaxSuccess 50 renderedIsParseable++ prop "identity backend output should parse into the same input" $ do++ let propertyParseAndOutputIdentity ∷ ProjectSystem → Property+ propertyParseAndOutputIdentity sys =+ let sys' = simplify sys+ parsed = runParser "test2" (render sys' allProps)+ in isRight parsed ==> parsed === Right sys'++ withMaxSuccess 50 propertyParseAndOutputIdentity++ it "should reject recursive equations" $ do++ let expectedError _ (Right _) = False+ expectedError key (Left s) =+ let l = last $ lines s+ in l == "definition of \"" ++ key ++ "\" is recursive"++ let wrap = T.unlines . map (<> ";\n")++ -- obvious+ let program1 = wrap ["root = a + b + root"]++ runParser "recursive1" program1 `shouldSatisfy` expectedError "root"++ let program2 = wrap [ "root = a + b"+ , "a = x * root" ]++ runParser "recursive2" program2 `shouldSatisfy` expectedError "a"++ let program3 = wrap [ "root = x + y"+ , "a = b * c"+ , "c = d -> a" ]++ runParser "recursive3" program3 `shouldSatisfy` expectedError "c"++ let program4 = wrap [ "root = a + y"+ , "d = x + root"+ , "a = b * c"+ , "c = d -> e" ]++ runParser "recursive4" program4 `shouldSatisfy` expectedError "c"
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}