From fdf2c61ed50da8ee423a844e4d15d4592ffc08fc Mon Sep 17 00:00:00 2001 From: Rodrigo Setti Date: Sat, 12 Aug 2017 11:10:44 -0700 Subject: [PATCH] rendering backend working --- .ghci | 1 + .hlint.yaml | 60 ++++++++++++ app/Main.hs | 112 +++++++++------------ examples/example1.plan | 52 ++++++++++ master-plan.cabal | 20 +++- src/MasterPlan/Backend/Graph.hs | 168 +++++++++++++++++++++++++++++++- src/MasterPlan/Backend/Html.hs | 18 ---- src/MasterPlan/Backend/Text.hs | 18 ---- src/MasterPlan/Data.hs | 34 ++++--- src/MasterPlan/Parser.hs | 4 +- test/MasterPlan/Arbitrary.hs | 2 +- test/MasterPlan/DataSpec.hs | 4 +- 12 files changed, 367 insertions(+), 126 deletions(-) create mode 100644 .hlint.yaml create mode 100644 examples/example1.plan delete mode 100644 src/MasterPlan/Backend/Html.hs delete mode 100644 src/MasterPlan/Backend/Text.hs diff --git a/.ghci b/.ghci index d396922..a0ae172 100644 --- a/.ghci +++ b/.ghci @@ -1 +1,2 @@ +:set prompt "%s\n>" :set -XUnicodeSyntax diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 0000000..11c2ea7 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,60 @@ +# HLint configuration file +# https://github.com/ndmitchell/hlint +########################## + +# This file contains a template configuration file, which is typically +# placed as .hlint.yaml in the root of your project + + +# Specify additional command line arguments +# +# - arguments: [--color, --cpp-simple, -XQuasiQuotes] + + +# Control which extensions/flags/modules/functions can be used +# +# - extensions: +# - default: false # all extension are banned by default +# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used +# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module +# +# - flags: +# - {name: -w, within: []} # -w is allowed nowhere +# +# - modules: +# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' +# - {name: Control.Arrow, within: []} # Certain modules are banned entirely +# +# - functions: +# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules + + +# Add custom hints for this project +# +# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" +# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} + + +# Turn on hints that are off by default +# +# Ban "module X(module X) where", to require a real export list +# - warn: {name: Use explicit module export list} +# +# Replace a $ b $ c with a . b $ c +# - group: {name: dollar, enabled: true} +# +# Generalise map to fmap, ++ to <> +# - group: {name: generalise, enabled: true} + + +# Ignore some builtin hints +# - ignore: {name: Use let} +# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules + + +# Define some custom infix operators +# - fixity: infixr 3 ~^#^~ + + +# To generate a suitable file for HLint do: +# $ hlint --default > .hlint.yaml diff --git a/app/Main.hs b/app/Main.hs index ab5626e..e1062f9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -16,69 +16,65 @@ import qualified Data.Map as M import Data.Maybe (catMaybes, fromMaybe) import Data.Semigroup ((<>)) import qualified Data.Text.IO as TIO -import qualified MasterPlan.Backend.Graph as BG -import qualified MasterPlan.Backend.Html as BH -import qualified MasterPlan.Backend.Identity as BI -import qualified MasterPlan.Backend.Text as BT +import MasterPlan.Backend.Graph import MasterPlan.Data import qualified MasterPlan.Parser as P import Options.Applicative -import System.IO (hPutStr, stderr) +import System.IO (hPutStr, stderr, stdin) -- |Type output from the command line parser -data Opts = Opts { inputPath :: FilePath - , outputPath :: Maybe FilePath - , projFilter :: ProjFilter -- ^ filter to consider - , properties :: [ProjProperty] -- ^ which properties to consider - , prioritize :: Bool -- ^ order by priority - , renderMode :: RenderMode } +data Opts = Opts { inputPath :: Maybe FilePath + , outputPath :: Maybe FilePath + , projFilter :: ProjFilter -- ^ filter to consider + , renderOptions :: RenderOptions } deriving (Show) -newtype ProjFilter = ProjFilter (ProjectBinding → Bool) +newtype ProjFilter = ProjFilter (ProjectSystem -> Project → Bool) noFilter ∷ ProjFilter -noFilter = ProjFilter $ const True +noFilter = ProjFilter $ const $ const True instance Show ProjFilter where show _ = "ProjFilter" -data RenderMode = IdentityRenderMode | TextRenderMode | GraphRenderMode | HtmlMode - deriving (Eq, Show) - readEnum ∷ [(String, a)] → ReadM a readEnum mapping = maybeReader $ flip lookup mapping -- |The command line parser cmdParser ∷ Parser Opts -cmdParser = Opts <$> strOption ( long "input" - <> short 'i' - <> help "plan file to read from" - <> value "master.plan" - <> showDefault - <> metavar "FILENAME" ) +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" + <> help "output file name (.png, .tif, .bmp, .jpg and .pdf supported)" <> metavar "FILENAME" )) <*> (filterParser <|> pure noFilter) - <*> (invertProps <$> many (option property ( long "hide" - <> help "hide a particular property" - <> metavar (intercalate "|" $ map fst propertyNames)))) - <*> switch ( long "prioritize" - <> short 'p' - <> help "prioritize projects to minimize cost") - <*> option parseRenderMode ( long "mode" - <> short 'm' - <> help "render mode" - <> metavar (intercalate "|" $ map fst nameRenderModes)) + <*> 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 ..] - nameRenderModes = [ ("identity", IdentityRenderMode) - , ("text", TextRenderMode) - , ("graph", GraphRenderMode) - , ("html", HtmlMode) ] property = readEnum propertyNames - parseRenderMode = readEnum nameRenderModes invertProps ∷ [ProjProperty] → [ProjProperty] invertProps l = filter (`notElem` l) $ map snd propertyNames @@ -88,8 +84,7 @@ cmdParser = Opts <$> strOption ( long "input" <> help "only display projects which progress is < N%" <> metavar "N" ) where - mkProgressFilter n (TaskProj _ _ _ p) = p*100 < n - mkProgressFilter _ _ = True + mkProgressFilter n sys p = progress sys p * 100 < n main ∷ IO () main = masterPlan =<< execParser opts @@ -100,38 +95,25 @@ main = masterPlan =<< execParser opts <> header "master-plan - project management tool for hackers" ) filterBinding ∷ ProjectSystem → ProjFilter → ProjectBinding → Maybe ProjectBinding -filterBinding sys (ProjFilter f) (ExpressionProj r p) = ExpressionProj r <$> filterProj p +filterBinding sys (ProjFilter f) (ExpressionProj r e) = ExpressionProj r <$> filterProj e where - filterProj (SumProj ps) = SumProj <$> filterProjs ps - filterProj (ProductProj ps) = ProductProj <$> filterProjs ps - filterProj (SequenceProj ps) = SequenceProj <$> filterProjs ps - filterProj rp@(RefProj n) = do b <- M.lookup n $ bindings sys - if f b then Just rp else Nothing + filterProj p@(SumProj ps) = filterHelper p ps SumProj + filterProj p@(ProductProj ps) = filterHelper p ps ProductProj + filterProj p@(SequenceProj ps) = filterHelper p ps SequenceProj + 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 $ NE.map filterProj ps) + filterBinding _ _ b = Just b masterPlan ∷ Opts → IO () masterPlan opts = - do contents <- TIO.readFile filename - case P.runParser filename contents of + 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) -> - render $ maybeOptimize $ ProjectSystem $ M.mapMaybe + do let sys' = optimizeSys $ ProjectSystem $ M.mapMaybe (filterBinding sys $ projFilter opts) b - where - filename = inputPath opts - - maybeOptimize = if prioritize opts then optimizeSys else id - - outputToFileOrOut s = case outputPath opts of - Nothing -> TIO.putStr s - Just path -> TIO.writeFile path s - - render sys = - case renderMode opts of - IdentityRenderMode -> outputToFileOrOut $ BI.render sys $ properties opts - TextRenderMode -> outputToFileOrOut $ BT.render sys $ properties opts - HtmlMode -> outputToFileOrOut $ BH.render sys $ properties opts - GraphRenderMode -> do let outfile = fromMaybe (filename ++ ".png") $ outputPath opts - BG.render outfile sys $ properties opts + let outfile = fromMaybe (fromMaybe "output" (outputPath opts) ++ ".pdf") $ outputPath opts + render outfile (renderOptions opts) sys' diff --git a/examples/example1.plan b/examples/example1.plan new file mode 100644 index 0000000..de15398 --- /dev/null +++ b/examples/example1.plan @@ -0,0 +1,52 @@ + +title(root) = "business"; +description(root) = "can we run a successful business"; +owner(root) = "CEO"; + +root = x + p; + +// ------- + +title(x) = "build technology"; +description(x) = "can we build the technology ourselves"; + +x = h * b; + +title(h) = "hire"; +description(h) = "can we attract and retain talent"; +cost(h) = 20; +owner(h) = "HR"; + +title(b) = "build"; +description(b) = "our technology can be built and scale"; + +b = phase1 -> phase2 -> phase3; + +title(phase1) = "validate prototype"; +trust(phase1) = 70%; +progress(phase1) = 100%; +owner(phase1) = "engineering"; + +title(phase2) = "launch in small market"; +trust(phase2) = 50%; +progress(phase2) = 32%; +owner(phase2) = "engineering"; + +title(phase3) = "scale nationwide"; +trust(phase3) = 20%; +owner(phase3) = "engineering"; + +// ------ + +title(p) = "tech partner"; +description(p) = "secure a tech partnership"; + +p = sa + sb; + +title(sa) = "supplier A"; trust(sa) = 90%; cost(sa) = 10; +url(sa) = "www.supplier.a.com"; +owner(sa) = "partnerships"; + +title(sb) = "supplier B"; trust(sb) = 60%; cost(sb) = 5; +url(sb) = "www.supplier.b.com"; +owner(sb) = "partnerships"; diff --git a/master-plan.cabal b/master-plan.cabal index df7361d..824411c 100644 --- a/master-plan.cabal +++ b/master-plan.cabal @@ -1,7 +1,16 @@ name: master-plan version: 0.1.0.0 synopsis: The project management tool for hackers --- description: +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 @@ -15,6 +24,10 @@ 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 @@ -34,6 +47,9 @@ library default-extensions: UnicodeSyntax build-depends: base , containers + , diagrams + , diagrams-lib + , diagrams-rasterific , megaparsec , mtl , text @@ -41,9 +57,7 @@ library exposed-modules: MasterPlan.Data , MasterPlan.Parser , MasterPlan.Backend.Graph - , MasterPlan.Backend.Html , MasterPlan.Backend.Identity - , MasterPlan.Backend.Text test-suite spec type: exitcode-stdio-1.0 diff --git a/src/MasterPlan/Backend/Graph.hs b/src/MasterPlan/Backend/Graph.hs index 97d3326..eec5e43 100644 --- a/src/MasterPlan/Backend/Graph.hs +++ b/src/MasterPlan/Backend/Graph.hs @@ -8,9 +8,171 @@ Stability : experimental Portability : POSIX -} {-# LANGUAGE UnicodeSyntax #-} -module MasterPlan.Backend.Graph (render) where +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} +module MasterPlan.Backend.Graph (render, RenderOptions(..)) where import MasterPlan.Data +import Diagrams.Prelude hiding (render) +import Diagrams.Backend.Rasterific +import qualified Data.Map as M +import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromMaybe, catMaybes) +import Text.Printf (printf) +import Data.List (intersperse) +--import Diagrams.TwoD.Text (Text) -render ∷ FilePath -> ProjectSystem → [ProjProperty] -> IO () -render = error "not implemented" +-- text :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any +-- text = texterific + +-- * Types + +-- |Generic tree +data Tree t n = Tree t n (NE.NonEmpty (Tree t n)) | Leaf n + +data NodeType = SumNode | ProductNode | SequenceNode + +-- |Data type used by the tree +data Node = Node (Maybe ProjectKey) + (Maybe ProjectProperties) + Cost + Trust + Progress + | NodeRef ProjectKey + +type RenderModel = Tree NodeType Node + +-- |Translates a ProjectSystem into a Tree Node +toRenderModel :: ProjectSystem -> ProjectKey -> Maybe RenderModel +toRenderModel sys rootK = bindingToRM rootK <$> M.lookup rootK (bindings sys) + where + bindingToRM :: ProjectKey -> ProjectBinding -> RenderModel + bindingToRM key (ExpressionProj prop p) = projToRM p (Just key) (Just prop) + bindingToRM key (TaskProj prop c t p) = Leaf $ Node (Just key) + (Just prop) + c t p + bindingToRM key (UnconsolidatedProj prop) = Leaf $ Node (Just key) + (Just prop) + defaultCost + defaultTrust + defaultProgress + mkNode :: (Node -> NE.NonEmpty RenderModel -> RenderModel) -> Project -> NE.NonEmpty Project -> Maybe ProjectKey -> Maybe ProjectProperties -> RenderModel + mkNode f p ps key prop = f (Node key prop + (cost sys p) + (trust sys p) + (progress sys p)) + $ NE.map (\p' -> projToRM p' Nothing Nothing) ps + + projToRM :: Project -> Maybe ProjectKey -> Maybe ProjectProperties -> RenderModel + projToRM p@(SumProj ps) = mkNode (Tree SumNode) p ps + projToRM p@(SequenceProj ps) = mkNode (Tree SequenceNode) p ps + projToRM p@(ProductProj ps) = mkNode (Tree ProductNode) p ps + projToRM (RefProj n) = -- TODO: avoid repeating + \k p -> case M.lookup n $ bindings sys of + Nothing -> Leaf $ Node k p 1 1 0 + Just b -> bindingToRM n b + +-- |how many children +treeSize :: Num a => Tree t n -> a +treeSize (Tree _ _ ts) = sum $ NE.map treeSize ts +treeSize _ = 1 + +data RenderOptions = RenderOptions { colorByProgress :: Bool + , renderWidth :: Integer + , renderHeight :: Integer + , rootKey :: ProjectKey + , whitelistedProps :: [ProjProperty] } + 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 :: QDiagram B V2 Double Any + dia = fromMaybe noRootEroor $ renderTree colorByP props <$> toRenderModel sys rootK + in renderRasterific fp (dims $ V2 (fromInteger w) (fromInteger h)) $ pad 1.05 $ centerXY dia + +renderTree :: Bool -> [ProjProperty] -> RenderModel -> QDiagram B V2 Double Any +renderTree colorByP props (Leaf n) = alignL $ renderNode colorByP props n +renderTree colorByP props t@(Tree ty n ts) = + (strut (V2 0 siz) <> alignL (centerY $ renderNode colorByP props n)) + ||| (translateX 2 typeSymbol # withEnvelope (mempty :: D V2 Double) <> hrule 4) + ||| centerY (headBar === treeBar (map ((* 6) . treeSize) ts')) + ||| centerY (vcat $ map renderSubTree ts') + where + siz = 12 * treeSize t + renderSubTree subtree = hrule 4 ||| renderTree colorByP props subtree + ts' = NE.toList ts + + headBar = strut $ V2 0 $ treeSize (NE.head ts) * 6 + + treeBar :: [Double] -> QDiagram B V2 Double Any + treeBar (s1:s2:ss) = vrule s1 === vrule s2 === treeBar (s2:ss) + treeBar [s1] = strut $ V2 0 s1 + treeBar _ = mempty + + typeSymbol = case ty of + SumNode -> text "+" <> circle 1 # fc white # lw 1 + ProductNode -> text "x" <> circle 1 # fc white # lw 1 + SequenceNode -> text ">" <> circle 1 # fc white # lw 1 + +renderNode :: Bool -> [ProjProperty] -> Node -> QDiagram B V2 Double Any +renderNode _ _ (NodeRef n) = pad 1.1 $ roundedRect 30 2 0.5 <> text n +renderNode colorByP props (Node key 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 -> strut (V2 0 $ snd s) <> fst s) hSizeAndSections + outerRect = rect 30 $ sum $ map snd hSizeAndSections + sectionsWithSep = vcat (intersperse (hrule 30 # dashingN [0.005, 0.005] 0 # lw 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 + (x, y, z) -> Just $ centerX $ fromMaybe mempty x + ||| fromMaybe mempty y + ||| fromMaybe mempty z + progressHeader = givenProp PProgress $ Just $ strut (V2 5 0) <> displayProgress p + titleHeader = givenProp PTitle $ ((strut (V2 20 0) <>) . bold . text . title) <$> prop + costHeader = givenProp PCost $ Just $ strut (V2 5 0) <> displayCost c + + 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 + (ma, mb) -> let st = strut (V2 15 0) + in Just $ centerX $ (st <> fromMaybe mempty ma) ||| + (st <> fromMaybe mempty mb) + + ownerSubSection = prop >>= owner >>= (pure . text) + trustSubSection = case t of + _ | PTrust `notElem` props -> Nothing + t' | t' == 1 -> Nothing + t' | t' == 0 -> Just $ text "impossible" + _ -> Just $ text ("trust = " ++ percentageText t) + + displayCost c' + | c' == 0 = mempty + | otherwise = text $ "(" ++ printf "%.1f" c' ++ ")" + displayProgress p' + | p' == 1 = text "done" + | p' == 0 = mempty + | otherwise = text $ percentageText p' + + fcColor = + fc $ if colorByP then + (if p <= 0.25 then pink else if p == 1 then lightgreen else lightyellow) + else white + + percentageText pct = show ((round $ pct * 100) :: Integer) ++ "%" diff --git a/src/MasterPlan/Backend/Html.hs b/src/MasterPlan/Backend/Html.hs deleted file mode 100644 index 7758abb..0000000 --- a/src/MasterPlan/Backend/Html.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-| -Module : MasterPlan.Backend.Html -Description : a backend that renders to a UI HTML -Copyright : (c) Rodrigo Setti, 2017 -License : MIT -Maintainer : rodrigosetti@gmail.com -Stability : experimental -Portability : POSIX --} -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE OverloadedStrings #-} -module MasterPlan.Backend.Html (render) where - -import MasterPlan.Data -import qualified Data.Text as T - -render ∷ ProjectSystem → [ProjProperty] -> T.Text -render = error "not implemented" diff --git a/src/MasterPlan/Backend/Text.hs b/src/MasterPlan/Backend/Text.hs deleted file mode 100644 index 41cc639..0000000 --- a/src/MasterPlan/Backend/Text.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-| -Module : MasterPlan.Backend.Text -Description : a backend that renders to a UI text -Copyright : (c) Rodrigo Setti, 2017 -License : MIT -Maintainer : rodrigosetti@gmail.com -Stability : experimental -Portability : POSIX --} -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE OverloadedStrings #-} -module MasterPlan.Backend.Text (render) where - -import MasterPlan.Data -import qualified Data.Text as T - -render ∷ ProjectSystem → [ProjProperty] -> T.Text -render = error "not implemented" diff --git a/src/MasterPlan/Data.hs b/src/MasterPlan/Data.hs index 102fbd1..c981e34 100644 --- a/src/MasterPlan/Data.hs +++ b/src/MasterPlan/Data.hs @@ -19,8 +19,10 @@ module MasterPlan.Data ( Project(..) , Trust , Cost , Progress - , rootKey , defaultProjectProps + , defaultCost + , defaultTrust + , defaultProgress , defaultTaskProj , cost , progress @@ -35,7 +37,7 @@ import Control.Monad.Writer import Data.Generics import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE -import qualified Data.Map as M +import qualified Data.Map as M (Map, lookup) import Data.Semigroup (sconcat) -- * Types @@ -84,17 +86,23 @@ instance Show ProjProperty where newtype ProjectSystem = ProjectSystem { bindings :: M.Map ProjectKey ProjectBinding } deriving (Eq, Show, Data, Typeable) -rootKey ∷ ProjectKey -rootKey = "root" - defaultProjectProps ∷ ProjectProperties -defaultProjectProps = ProjectProperties { title = rootKey +defaultProjectProps = ProjectProperties { title = "?" , description = Nothing , url = Nothing , owner = Nothing } +defaultCost :: Cost +defaultCost = 0 + +defaultTrust :: Trust +defaultTrust = 1 + +defaultProgress :: Progress +defaultProgress = 0 + defaultTaskProj ∷ ProjectProperties → ProjectBinding -defaultTaskProj pr = TaskProj pr 0 1 0 +defaultTaskProj pr = TaskProj pr defaultCost defaultTrust defaultProgress -- | Expected cost cost ∷ ProjectSystem → Project → Cost @@ -102,8 +110,8 @@ cost sys (RefProj n) = case M.lookup n (bindings sys) of Just (TaskProj _ c _ p) -> c * (1-p) -- cost is weighted by remaining progress Just (ExpressionProj _ p) -> cost sys p -- TODO: avoid cyclic - Just (UnconsolidatedProj _) -> 0 -- default - Nothing -> 0 -- should not happen + Just (UnconsolidatedProj _) -> defaultCost -- default + Nothing -> error $ "project \"" ++ n ++ "\" is undefined" -- should not happen cost sys (SequenceProj ps) = costConjunction sys ps cost sys (ProductProj ps) = costConjunction sys ps cost sys (SumProj ps) = @@ -125,8 +133,8 @@ trust sys (RefProj n) = case M.lookup n (bindings sys) of Just (TaskProj _ _ t p) -> p + t * (1-p) Just (ExpressionProj _ p) -> trust sys p -- TODO: avoid cyclic - Just (UnconsolidatedProj _) -> 1 -- default - Nothing -> 0 -- should not happen + Just (UnconsolidatedProj _) -> defaultTrust -- default + Nothing -> error $ "project \"" ++ n ++ "\" is undefined" -- should not happen trust sys (SequenceProj ps) = trustConjunction sys ps trust sys (ProductProj ps) = trustConjunction sys ps trust sys (SumProj ps) = @@ -140,8 +148,8 @@ progress sys (RefProj n) = case M.lookup n (bindings sys) of Just (TaskProj _ _ _ p) -> p Just (ExpressionProj _ p) -> progress sys p -- TODO: avoid cyclic - Just (UnconsolidatedProj _) -> 0 -- default - Nothing -> 0 -- should not happen + Just (UnconsolidatedProj _) -> defaultProgress -- default + Nothing -> error $ "project \"" ++ n ++ "\" is undefined" -- should not happen progress sys (SequenceProj ps) = progressConjunction sys ps progress sys (ProductProj ps) = progressConjunction sys ps progress sys (SumProj ps) = maximum $ NE.map (progress sys) ps diff --git a/src/MasterPlan/Parser.hs b/src/MasterPlan/Parser.hs index 5658452..289a437 100644 --- a/src/MasterPlan/Parser.hs +++ b/src/MasterPlan/Parser.hs @@ -146,9 +146,7 @@ dependencies sys = everything (++) ([] `mkQ` collectDep) projectSystem :: Parser ProjectSystem projectSystem = do between sc eof definitionSeq - ps <- lift get - unless (M.member rootKey $ bindings ps) $ fail $ "expected project \"" ++ rootKey ++ "\" to be defined." - pure ps + lift get where definitionSeq = void $ endBy1 definition (symbol ";") diff --git a/test/MasterPlan/Arbitrary.hs b/test/MasterPlan/Arbitrary.hs index 8d155fa..54b7fd4 100644 --- a/test/MasterPlan/Arbitrary.hs +++ b/test/MasterPlan/Arbitrary.hs @@ -27,7 +27,7 @@ instance Arbitrary ProjectSystem where arbitrary = do bs <- replicateM (length testingKeys) arbitrary rootB <- ExpressionProj <$> arbitrary <*> arbitrary - pure $ ProjectSystem $ M.insert rootKey rootB $ M.fromList $ zip testingKeys bs + pure $ ProjectSystem $ M.insert "root" rootB $ M.fromList $ zip testingKeys bs shrink (ProjectSystem bs) = map ProjectSystem $ concatMap shrinkOne testingKeys diff --git a/test/MasterPlan/DataSpec.hs b/test/MasterPlan/DataSpec.hs index 4138a1a..f7dd858 100644 --- a/test/MasterPlan/DataSpec.hs +++ b/test/MasterPlan/DataSpec.hs @@ -81,7 +81,7 @@ spec = do (counterexample "disagree on cost" $ cost' `eq` cost sys p) .&&. (counterexample "disagree on trust" $ trust' `eq` trust sys p) where - p = RefProj rootKey + p = RefProj "root" (trust', cost') = evalState (monteCarloTrustAndCost 50000 sys p) g property monteCarloAndAnalyticalAgree @@ -103,7 +103,7 @@ spec = do let propSimplifyIsStable :: ProjectSystem -> Property propSimplifyIsStable sys = let sys' = simplify sys - p = RefProj rootKey + p = RefProj "root" in cost sys p `eq` cost sys' p .&&. trust sys p `eq` trust sys' p property propSimplifyIsStable