mirror of
https://github.com/rodrigosetti/master-plan.git
synced 2024-11-21 17:13:41 +03:00
rendering backend working
This commit is contained in:
Rodrigo Setti
parent
6a78e50ffa
commit
fdf2c61ed5
60
.hlint.yaml
Normal file
60
.hlint.yaml
Normal file
@ -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
|
||||
104
app/Main.hs
104
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
|
||||
data Opts = Opts { inputPath :: Maybe FilePath
|
||||
, outputPath :: Maybe FilePath
|
||||
, projFilter :: ProjFilter -- ^ filter to consider
|
||||
, properties :: [ProjProperty] -- ^ which properties to consider
|
||||
, prioritize :: Bool -- ^ order by priority
|
||||
, renderMode :: RenderMode }
|
||||
, 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)
|
||||
<*> 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))))
|
||||
<*> 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))
|
||||
where
|
||||
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'
|
||||
|
||||
52
examples/example1.plan
Normal file
52
examples/example1.plan
Normal file
@ -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";
|
||||
@ -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
|
||||
|
||||
@ -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) ++ "%"
|
||||
|
||||
@ -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"
|
||||
@ -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"
|
||||
@ -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
|
||||
|
||||
@ -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 ";")
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user