master-plan 0.3.0 → 0.3.1

raw patch · 12 files changed

+430/−500 lines, 12 filesdep −containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• README.md +5/−4
• app/Main.hs +31/−31
• master-plan.cabal +1/−4
• src/MasterPlan/Backend/Graph.hs +48/−96
• src/MasterPlan/Backend/Identity.hs +77/−55
• src/MasterPlan/Data.hs +91/−112
• src/MasterPlan/Internal/Debug.hs +13/−23
• src/MasterPlan/Parser.hs +62/−47
• test/MasterPlan/Arbitrary.hs +17/−44
• test/MasterPlan/DataSpec.hs +50/−58
• test/MasterPlan/ParserSpec.hs +28/−26

@@ -7,6 +7,13 @@  ## [Unreleased] +## [0.3.1] - 2017-08-18++ * New option flag: `--strict` that will instruct the parser to reject plans+   with undefined projects (_i.e._ used in expressions but never defined).+ * Fix: make cost and trust value rendering consistent for leaf and non-leaf+   projects - now they are partial everywhere.+ ## [0.3.0] - 2017-08-17  New option flag: `--render-parse-error` which will render the image with the

@@ -48,9 +48,9 @@ ``` master-plan - project management tool for hackers -Usage: master-plan [FILENAME] [-o|--output FILENAME] [--progress-below N]-                   [--render-parse-error] [-c|--color] [-w|--width NUMBER]-                   [--height NUMBER] [-r|--root NAME]+Usage: master-plan [FILENAME] [-o|--output FILENAME] [-r|--root NAME]+                   [--progress-below N] [--render-parse-error] [--strict]+                   [-c|--color] [-w|--width NUMBER] [--height NUMBER]                    [--hide title|description|url|owner|cost|trust|progress]   See documentation on how to write project plan files @@ -58,13 +58,14 @@   FILENAME                 plan file to read from (default from stdin)   -o,--output FILENAME     output file name (.png, .tif, .bmp, .jpg and .pdf                            supported)+  -r,--root NAME           name of the root project definition (default: "root")   --progress-below N       only display projects which progress is < N%   --render-parse-error     instead of printing parsing errors, render as an                            image+  --strict                 strict parsing: every project has to be defined   -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

@@ -12,7 +12,6 @@  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@@ -26,18 +25,16 @@ -- |Type output from the command line parser data Opts = Opts { inputPath          :: Maybe FilePath                  , outputPath         :: Maybe FilePath+                 , rootKey            :: ProjectKey -- ^ name of the root project                  , projFilter         :: ProjFilter -- ^ filter to consider                  , renderParsingError :: Bool -- ^ will render the parsing error instead of printing+                 , parseStrict        :: Bool -- ^ every project has to be defined                  , renderOptions      :: RenderOptions }-  deriving (Show) -newtype ProjFilter = ProjFilter (ProjectSystem → ProjectExpr → Bool)+type ProjFilter = ProjectExpr → Bool  noFilter ∷ ProjFilter-noFilter = ProjFilter $ const $ const True--instance Show ProjFilter where-  show _ = "ProjFilter"+noFilter = const True  readEnum ∷ [(String, a)] → ReadM a readEnum mapping = maybeReader $ flip lookup mapping@@ -50,9 +47,17 @@                                          <> short 'o'                                          <> help "output file name (.png, .tif, .bmp, .jpg and .pdf supported)"                                          <> metavar "FILENAME" ))+                 <*> strOption ( long "root"+                               <> short 'r'+                               <> help "name of the root project definition"+                               <> value "root"+                               <> showDefault+                               <> metavar "NAME")                  <*> (filterParser <|> pure noFilter)                  <*> switch ( long "render-parse-error"                             <> help "instead of printing parsing errors, render as an image")+                 <*> switch ( long "strict"+                            <> help "strict parsing: every project has to be defined")                  <*> renderOptionsParser   where     renderOptionsParser ∷ Parser RenderOptions@@ -68,12 +73,6 @@                                                          <> help "height of the output image"                                                          <> value (-1)                                                          <> metavar "NUMBER")-                                        <*> (ProjectKey <$> strOption ( long "root"-                                                                     <> short 'r'-                                                                     <> help "name of the root project definition"-                                                                     <> value "root"-                                                                     <> showDefault-                                                                     <> metavar "NAME"))                                         <*> (invertProps <$> many (option property ( long "hide"                                                                                    <> help "hide a particular property"                                                                                    <> metavar (intercalate "|" $ map fst propertyNames))))@@ -84,11 +83,11 @@     invertProps l = filter (`notElem` l) $ map snd propertyNames      filterParser ∷ Parser ProjFilter-    filterParser = (ProjFilter . mkProgressFilter . Progress) <$> option auto ( long "progress-below"+    filterParser = (mkProgressFilter . Progress) <$> option auto ( long "progress-below"                                                                               <> help "only display projects which progress is < N%"                                                                               <> metavar "N" )       where-        mkProgressFilter n sys p = progress sys p * 100 < n+        mkProgressFilter n p = progress p * 100 < n  main ∷ IO () main = masterPlan =<< execParser opts@@ -98,28 +97,29 @@      <> 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)+filterProj ∷ ProjFilter -> ProjectExpr → Maybe ProjectExpr+filterProj f p@(Sum r ps)      = filterHelper p f ps (Sum r)+filterProj f p@(Product r ps)  = filterHelper p f ps (Product r)+filterProj f p@(Sequence r ps) = filterHelper p f ps (Sequence r)+filterProj f p                 = if f p then Just p else Nothing -filterBinding _   _ b = Just b+filterHelper :: ProjectExpr+             -> ProjFilter+             -> NE.NonEmpty ProjectExpr+             -> (NE.NonEmpty ProjectExpr -> ProjectExpr)+             -> Maybe ProjectExpr+filterHelper p f ps c = if f p then c <$> filterProjs ps else Nothing+  where+ filterProjs ps' = NE.nonEmpty (catMaybes $ NE.toList $ filterProj f <$> ps')  masterPlan ∷ Opts → IO () masterPlan opts =     do contents <- maybe (TIO.hGetContents stdin) TIO.readFile $ inputPath opts        let outfile = fromMaybe (fromMaybe "output" (outputPath opts) ++ ".pdf") $ outputPath opts-       case P.runParser (fromMaybe "stdin" $ inputPath opts) contents of+       case P.runParser (parseStrict opts) (fromMaybe "stdin" $ inputPath opts) contents (rootKey opts) of           Left e    -> if renderParsingError opts                         then renderText outfile (renderOptions opts) (lines e)                         else die e-          Right sys@(ProjectSystem b) ->-            do let sys' = prioritizeSys $ ProjectSystem $ M.mapMaybe-                                                    (filterBinding sys $ projFilter opts) b-               render outfile (renderOptions opts) sys'+          Right p ->+            do let p' = fromMaybe defaultAtomic $ prioritize <$> filterProj (projFilter opts) p+               render outfile (renderOptions opts) p'

@@ -1,5 +1,5 @@ name:                master-plan-version:             0.3.0+version:             0.3.1 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@@ -36,7 +36,6 @@   ghc-options:         -Wall   default-extensions:  UnicodeSyntax   build-depends:       base >= 4.5 && < 5-                     , containers                      , master-plan                      , optparse-applicative                      , text@@ -47,7 +46,6 @@     ghc-options:         -Wall     default-extensions:  UnicodeSyntax     build-depends:       base >= 4.5 && < 5-                       , containers                        , diagrams                        , diagrams-lib                        , diagrams-rasterific@@ -69,7 +67,6 @@   default-language: Haskell2010   build-depends:    base >= 4.5 && < 5                   , QuickCheck-                  , containers                   , hspec                   , master-plan                   , mtl

@@ -16,13 +16,9 @@                                 , renderText                                 , RenderOptions(..)) where -import           Control.Applicative         ((<|>)) import           Control.Monad.State import           Data.List                   (intersperse, isSuffixOf)-import qualified Data.List.NonEmpty          as NE-import qualified Data.Map                    as M import           Data.Maybe-import           Data.Tree import           Diagrams.Backend.Rasterific import           Diagrams.Prelude            hiding (Product, Sum, render) import           Diagrams.TwoD.Text@@ -83,77 +79,17 @@               -> QDiagram b V2 n Any textOverflow = textOverflow' FontSlantNormal FontWeightNormal --- * Types--data NodeType = SumNode | ProductNode | SequenceNode | AtomicNode---- |Data type used by the tree-data PNode = PNode (Maybe ProjectKey)-                 (Maybe ProjectProperties)-                 Cost-                 Trust-                 Progress-          | NodeRef ProjectKey--type RenderModel = Tree (NodeType, PNode)--mkLeaf :: PNode -> RenderModel-mkLeaf a = Node (AtomicNode, a) []---- |Translates a ProjectSystem into a Tree PNode-toRenderModel :: ProjectSystem -> ProjectKey -> State [ProjectKey] (Maybe RenderModel)-toRenderModel sys rootK = case M.lookup rootK (bindings sys) of-                            Nothing -> pure Nothing-                            Just b  -> Just <$> bindingToRM rootK b-  where-    bindingToRM :: ProjectKey -> Binding -> State [ProjectKey] RenderModel-    bindingToRM key (BindingExpr prop p) = projToRM p (Just key) (Just prop)-    bindingToRM key (BindingAtomic prop c t p) = pure $ mkLeaf $ PNode (Just key)-                                                                       (Just prop)-                                                                       c t p--    mkNode :: (PNode -> [RenderModel] -> RenderModel)-           -> ProjectExpr-           -> NE.NonEmpty ProjectExpr-           -> Maybe ProjectKey-           -> Maybe ProjectProperties-           -> State [ProjectKey] RenderModel-    mkNode f p ps key prop = f (PNode key prop-                                     (cost sys p)-                                     (trust sys p)-                                     (progress sys p))-                               <$> mapM (\p' -> projToRM p' Nothing Nothing) (NE.toList ps)--    projToRM :: ProjectExpr -> Maybe ProjectKey -> Maybe ProjectProperties -> State [ProjectKey] RenderModel-    projToRM p@(Sum ps) = mkNode (\x -> Node (SumNode, x)) p ps-    projToRM p@(Sequence ps) = mkNode (\x -> Node (SequenceNode, x)) p ps-    projToRM p@(Product ps) = mkNode (\x -> Node (ProductNode, x)) p ps-    projToRM (Reference n) =-      \k p -> case M.lookup n $ bindings sys of-                Nothing -> pure $ Node (AtomicNode, PNode k (p <|> pure defaultProjectProps {title=getProjectKey n}) defaultCost defaultTrust defaultProgress) []-                Just b -> do alreadyProcessed <- gets (n `elem`)-                             if alreadyProcessed-                               then pure $ Node (AtomicNode, NodeRef $ ProjectKey $ bindingTitle b) []-                               else modify (n:) >> bindingToRM n b---- |how many leaf nodes-leafCount :: Tree a -> Double-leafCount (Node _ []) = 1-leafCount (Node _ ts) = sum $ leafCount <$> ts- -- |Options for rendering data RenderOptions = RenderOptions { colorByProgress  :: Bool -- ^Whether to color boxes depending on progress                                    , renderWidth      :: Integer -- ^The width of the output image                                    , renderHeight     :: Integer -- ^The height of the output image-                                   , rootKey          :: ProjectKey -- ^The name of the root project-                                   , whitelistedProps :: [ProjAttribute] -- ^Properties that should be rendered+                                   , whitelistedAttrs :: [ProjAttribute] -- ^Attributes that should be rendered                                    } deriving (Eq, Show)  -- | The main rendering function-render ∷ FilePath -> RenderOptions-> ProjectSystem → IO ()-render fp (RenderOptions colorByP w h rootK props) sys =-  let noRootEroor = texterific $ "no project named \"" ++ getProjectKey rootK ++ "\" found."-      dia = fromMaybe noRootEroor $ renderTree colorByP props <$> evalState (toRenderModel sys rootK) []+render ∷ FilePath -> RenderOptions-> ProjectExpr → IO ()+render fp (RenderOptions colorByP w h attrs) proj =+  let dia = evalState (renderProject colorByP attrs proj) []   in renderRasterific fp (dims2D (fromInteger w) (fromInteger h)) $ bgFrame 1 white $ centerXY dia  -- |Render a multi-line text to file@@ -162,38 +98,51 @@   let dia = multilineText (0.1 :: Float) ss   in renderRasterific fp (dims2D (fromInteger w) (fromInteger h)) $ bgFrame 1 white $ centerXY dia -renderTree :: Bool -> [ProjAttribute] -> RenderModel -> QDiagram B V2 Double Any-renderTree colorByP props (Node (_, n) [])    = alignL $ renderNode colorByP props n-renderTree colorByP props x@(Node (ty, n) ts@(t:_)) =-    (strutY (12 * leafCount x) <> alignL (centerY $ renderNode colorByP props n))-    |||  (translateX 2 typeSymbol # withEnvelope (mempty :: D V2 Double) <> hrule 4 # lwO 2)-    |||  centerY (headBar === treeBar sizes)-    |||  centerY (vcat $ map renderSubTree ts)-  where-    sizes = map ((* 6) . leafCount) ts-    renderSubTree subtree = hrule 4 # lwO 2 ||| renderTree colorByP props subtree+-- |Monad that keep state of all projects rendered so far+type AvoidRedundancy = State [ProjectExpr] -    headBar = strutY $ leafCount t * 6+renderProject :: Bool -> [ProjAttribute] -> ProjectExpr -> AvoidRedundancy (QDiagram B V2 Double Any)+renderProject _        _     (Annotated _)  = undefined+renderProject colorByP attrs p@Atomic {}    = pure $ alignL $ renderNode colorByP attrs p+renderProject colorByP attrs proj =+    do alreadyRendered <- gets (proj `elem`)+       case title =<< properties proj of+         Just n | alreadyRendered -> pure $ renderReference n+         _ -> do modify (proj:)+                 subtrees <- mapM renderSubTree $ subprojects proj+                 let sizesY = map (diameter unitY) subtrees+                 let headBar = case sizesY of+                                []  -> mempty+                                s:_ -> strutY (s/2)+                 pure $ (strutY (sum sizesY) <> alignL (centerY $ renderNode colorByP attrs proj))+                        |||  (translateX 2 typeSymbol # withEnvelope (mempty :: D V2 Double) <> hrule 4 # lwO 2)+                        |||  centerY (headBar === treeBar sizesY)+                        |||  centerY (vcat subtrees)+  where+    renderSubTree subtree = (hrule 4 # lwO 2 |||) <$> renderProject colorByP attrs subtree+    renderReference refName = text refName <> roundedRect 30 2 0.5 # lwO 2 # fc white # dashingN [0.005, 0.005] 0      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 (s1:s2:ss) = vrule (s1/2) # lwO 2 === vrule (s2/2) # lwO 2 === treeBar (s2:ss)+    treeBar [s1] = strutY (s1/2)     treeBar _ = mempty      typeSymbol =-      let txt = case ty of-                    SumNode      -> text "+"-                    ProductNode  -> text "x"-                    SequenceNode -> text "->"-                    AtomicNode   -> mempty-      in txt # fontSizeL 2 # bold <> roundedRect 3 2 1 # fc white # lwO 1+      let txt = case proj of+                    Sum {}      -> text "+"+                    Product {}  -> text "x"+                    Sequence {} -> text "->"+                    _           -> mempty+      in txt # fontSizeL 2 # bold <> extrudeTop 2 (extrudeBottom 2 (roundedRect 3 2 1 # fc white # lwO 1)) -renderNode :: Bool -> [ProjAttribute] -> PNode -> QDiagram B V2 Double Any-renderNode _        _     (NodeRef (ProjectKey n)) =-   text n <> roundedRect 30 12 0.5 # lwO 2 # fc white # dashingN [0.005, 0.005] 0-renderNode colorByP props (PNode _   prop c t p) =-   centerY nodeDia <> strutY 12+renderNode :: Bool -> [ProjAttribute] -> ProjectExpr -> QDiagram B V2 Double Any+renderNode colorByP attrs proj =+   centerY $ extrudeTop 2 $ extrudeBottom 2 nodeDia   where+    c = cost proj+    t = trust proj+    p = progress proj+    prop = properties proj     nodeDia =       let sections = if isJust titleHeader                       then catMaybes [ headerSection@@ -211,14 +160,17 @@                           l -> Just $ strutY 2 <> strutX nodeW <> mconcat (catMaybes l)      givenProp :: ProjAttribute -> Maybe a -> Maybe a-    givenProp pro x = if pro `elem` props then x else Nothing+    givenProp pro x = if pro `elem` attrs then x else Nothing      headerSection = case [progressHeader, titleHeader, costHeader] of                         [Nothing, Nothing, Nothing] -> Nothing                         l -> Just $ strutY 2 <> strutX nodeW <> mconcat (catMaybes l)     progressHeader = givenProp PProgress $ Just $ displayProgress p # translateX (-nodeW/2 + 1)-    titleHeader = givenProp PTitle $-                    (centerXY . textOverflow' FontSlantNormal FontWeightBold 1 30 0.1 . title) <$> prop++    titleHeader :: Maybe (QDiagram B V2 Double Any)+    titleHeader = givenProp PTitle $ prop+                                   >>= title+                                   >>= (pure . centerXY . textOverflow' FontSlantNormal FontWeightBold 1 30 0.1)     costHeader = givenProp PCost $ Just $ displayCost c # translateX (nodeW/2 - 1)      descriptionSection, urlSection, bottomSection :: Maybe (QDiagram B V2 Double Any)@@ -237,7 +189,7 @@     trustHeader = translateX (-nodeW/2+1) <$> trustHeader' leftText      trustHeader' txt = case t of-                          _  | PTrust `notElem` props -> Nothing+                          _  | PTrust `notElem` attrs -> Nothing                           t' | t' == defaultTrust -> Nothing                           t' | t' == 0 -> Just $ txt "impossible"                           _  -> Just $ txt ("trust = " ++ percentageText (getTrust t))

@@ -12,81 +12,103 @@ module MasterPlan.Backend.Identity (render) where  import           Control.Monad      (when)-import           Control.Monad.RWS  (RWS, evalRWS, gets, modify, tell)-import           Data.Generics-import           Data.List          (nub)+import           Control.Monad.RWS  hiding (Product, Sum)+import           Data.List          (intersperse) import qualified Data.List.NonEmpty as NE-import qualified Data.Map           as M-import           Data.Maybe         (isJust) import           Data.Monoid        ((<>)) import qualified Data.Text          as T import           MasterPlan.Data +type RenderMonad a = RWS [ProjAttribute] T.Text [(ProjectKey, Project a)]+ -- |Plain text renderer-render ∷ ProjectSystem → [ProjAttribute] -> T.Text-render (ProjectSystem bs) whitelist =-   snd $ evalRWS (renderName "root" >> renderRest) whitelist bs+render ∷ Project a → [ProjAttribute] -> T.Text+render proj whitelist =+   snd $ evalRWS (renderDefinition "root" proj) whitelist []  where-   renderRest = gets M.keys >>= mapM_ renderName+   renderDefinition key p =+     do tell $ T.pack key+        when (hasAttribute p) $ do+           tell " {\n"+           renderAttr p+           tell "}"+        case p of+          Atomic {}    -> pure ()+          Annotated {} -> pure ()+          p'           -> tell " " >> expression False p'+        tell "\n;"+        modify $ filter ((/= key) . fst)+        remainingBindings <- get+        case remainingBindings of+          []        -> pure ()+          (k, p'):_ -> renderDefinition k p' -type RenderMonad = RWS [ProjAttribute] T.Text (M.Map ProjectKey Binding)+   expression :: Bool -> Project a -> RenderMonad a ()+   expression parens p@(Product _ ps)  = maybeBinding p $ combinedE parens "*" ps+   expression parens p@(Sequence _ ps) = maybeBinding p $ combinedE parens "->" ps+   expression parens p@(Sum _ ps)      = maybeBinding p $ combinedE parens "+" ps+   expression _      p@Atomic {}       = maybeBinding p $ tell $ T.pack $ mkKey p+   expression _ _                      = pure () -renderName ∷ ProjectKey → RenderMonad ()-renderName projName =-  do mb <- gets $ M.lookup projName-     case mb of-       Nothing -> pure ()-       Just b  -> do tell $ T.pack $ getProjectKey projName-                     when (hasAttribute b) $ do-                       tell " {\n"-                       renderAttr b-                       tell "}"-                     case b of-                       BindingExpr _ e -> tell $ " " <> expressionToStr False e <> ";\n"-                       _ -> tell ";\n"-                     modify $ M.delete projName-                     mapM_ renderName $ dependencies b- where-   hasAttribute (BindingExpr props _) = hasProperty props-   hasAttribute (BindingAtomic props c t p) =  hasProperty props+   maybeBinding :: Project a -> RenderMonad a () -> RenderMonad a ()+   maybeBinding p action+    | hasAttribute p = let key = mkKey p+                        in modify ((key, p):) >> tell (T.pack key)+    | otherwise = action++   mkKey :: Project a -> String+   mkKey (Annotated _)        = "?"+   mkKey (Product props _)    = maybe "?" toId $ title props+   mkKey (Sequence props _)   = maybe "?" toId $ title props+   mkKey (Sum props _)        = maybe "?" toId $ title props+   mkKey (Atomic props _ _ _) =  maybe "?" toId $ title props++   toId :: String -> String+   toId = mconcat . words++   combinedE :: Bool -> T.Text -> NE.NonEmpty (Project a) -> RenderMonad a ()+   combinedE parens op ps = let sube = expression True <$> NE.toList ps+                                s = sequence_ $ intersperse (tell $ " " <> op <> " ") sube+                            in  if parens && length ps > 1+                                    then tell "(" >> s >> tell ")"+                                    else s++   hasAttribute (Annotated _) = False+   hasAttribute (Product props _) = hasProperty props+   hasAttribute (Sequence props _) = hasProperty props+   hasAttribute (Sum props _) = hasProperty props+   hasAttribute (Atomic props c t p) =  hasProperty props                                             || c /= defaultCost                                             || t /= defaultTrust                                             || p  /= defaultProgress-   hasProperty props =  title props /= getProjectKey projName-                     || isJust (description props)-                     || isJust (owner props)-                     || isJust (url props) +   hasProperty props =  isNonEmpty (title props)+                     || isNonEmpty (description props)+                     || isNonEmpty (owner props)+                     || isNonEmpty (url props)++   isNonEmpty Nothing   = False+   isNonEmpty (Just "") = False+   isNonEmpty (Just _)  = True+    percentage n = T.pack $ show (n * 100) <> "%" -   renderAttr (BindingExpr props _) = renderProps props-   renderAttr (BindingAtomic props c t p) =+   renderAttr (Annotated _) = pure ()+   renderAttr (Product props _) = renderProps props+   renderAttr (Sequence props _) = renderProps props+   renderAttr (Sum props _) = renderProps props+   renderAttr (Atomic props c t p) =      do renderProps props         when (c /= defaultCost) $ tell $ "cost " <> T.pack (show $ getCost c) <> "\n"         when (t /= defaultTrust) $ tell $ "trust " <> percentage (getTrust t) <> "\n"         when (p /= defaultProgress) $ tell $ "progress " <> percentage (getProgress p) <> "\n" -   renderProps :: ProjectProperties -> RenderMonad ()-   renderProps p = do let maybeRender :: T.Text -> Maybe String -> RenderMonad ()-                          maybeRender n = maybe (pure ()) (\x -> tell $ n <> " " <> T.pack (show x) <> "\n")-                      when (title p /= getProjectKey projName) $-                        tell $ "title " <> T.pack (show $ title p) <> "\n"+   renderProps :: ProjectProperties -> RenderMonad a ()+   renderProps p = do let maybeRender :: T.Text -> Maybe String -> RenderMonad a ()+                          maybeRender _ Nothing   = pure ()+                          maybeRender _ (Just "") = pure ()+                          maybeRender n (Just x)  = tell $ n <> " " <> T.pack (show x) <> "\n"+                      maybeRender "title" (title p)                       maybeRender "description" (description p)                       maybeRender "url" (url p)                       maybeRender "owner" (owner p)--   combinedEToStr parens op ps = let sube = map (expressionToStr True) $ NE.toList ps-                                     s = T.intercalate (" " <> op <> " ") sube-                                  in if parens && length ps > 1 then "(" <> s <> ")" else s--   expressionToStr :: Bool -> ProjectExpr -> T.Text-   expressionToStr _      (Reference (ProjectKey n)) = T.pack n-   expressionToStr parens (Product ps)               = combinedEToStr parens "*" ps-   expressionToStr parens (Sequence ps)              = combinedEToStr parens "->" ps-   expressionToStr parens (Sum ps)                   = combinedEToStr parens "+" ps--dependencies ∷ Binding → [ProjectKey]-dependencies = nub . everything (++) ([] `mkQ` collectDep)-  where-    collectDep (Reference n) = [n]-    collectDep _             = []

@@ -12,11 +12,10 @@ {-# LANGUAGE OverloadedLists            #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE UnicodeSyntax              #-}-module MasterPlan.Data ( ProjectExpr(..)+module MasterPlan.Data ( ProjectExpr+                       , ProjectKey+                       , Project(..)                        , ProjectProperties(..)-                       , ProjectSystem(..)-                       , Binding(..)-                       , ProjectKey(..)                        , ProjAttribute(..)                        , Trust(..)                        , Cost(..)@@ -25,24 +24,25 @@                        , defaultCost                        , defaultTrust                        , defaultProgress-                       , defaultTaskProj-                       , bindingTitle+                       , defaultAtomic+                       , properties                        , cost                        , progress                        , trust                        , simplify-                       , simplifyProj-                       , prioritizeSys-                       , prioritizeProj ) where+                       , subprojects+                       , prioritize ) where  import           Data.Generics import           Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE-import qualified Data.Map           as M-import           Data.String        (IsString)+import           Data.Void          (Void)  -- * Types +-- |When using to reference projects by name+type ProjectKey = String+ newtype Trust = Trust { getTrust :: Float }   deriving (Show, Eq, Data, Typeable, Ord, Num, Real, RealFrac, Fractional) newtype Cost = Cost { getCost :: Float }@@ -50,25 +50,18 @@ newtype Progress = Progress { getProgress :: Float }   deriving (Show, Eq, Data, Typeable, Ord, Num, Real, RealFrac, Fractional) -newtype ProjectKey = ProjectKey { getProjectKey :: String }-  deriving (Show, Eq, Data, Typeable, Ord, IsString)- -- |Structure of a project expression-data ProjectExpr = Sum (NE.NonEmpty ProjectExpr)-             | Product (NE.NonEmpty ProjectExpr)-             | Sequence (NE.NonEmpty ProjectExpr)-             | Reference ProjectKey-            deriving (Eq, Show, Data, Typeable)+data Project e = Sum ProjectProperties (NE.NonEmpty (Project e))+               | Product ProjectProperties (NE.NonEmpty (Project e))+               | Sequence ProjectProperties (NE.NonEmpty (Project e))+               | Atomic ProjectProperties Cost Trust Progress+               | Annotated e+              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-                   deriving (Eq, Show, Data, Typeable)+type ProjectExpr = Project Void  -- |Any binding (with a name) may have associated properties-data ProjectProperties = ProjectProperties { title       :: String+data ProjectProperties = ProjectProperties { title       :: Maybe String                                            , description :: Maybe String                                            , url         :: Maybe String                                            , owner       :: Maybe String@@ -86,13 +79,8 @@   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 = "?"+defaultProjectProps = ProjectProperties { title = Nothing                                         , description = Nothing                                         , url = Nothing                                         , owner = Nothing }@@ -106,108 +94,99 @@ 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+defaultAtomic :: Project a+defaultAtomic = Atomic defaultProjectProps defaultCost defaultTrust defaultProgress  -- | Expected cost-cost ∷ ProjectSystem → ProjectExpr → Cost-cost sys (Reference n) =-  case M.lookup n (bindings sys) of-    Just (BindingAtomic _ (Cost c) _ (Progress p)) -> Cost $ c * (1 - p) -- cost is weighted by remaining progress-    Just (BindingExpr _ p)                         -> cost sys p -- TODO:0 avoid cyclic-    Nothing                                        -> defaultCost -- mentioned but no props neither task defined-cost sys (Sequence ps) = costConjunction sys ps-cost sys (Product ps) = costConjunction sys ps-cost sys (Sum ps) =+cost ∷ ProjectExpr → Cost+cost (Atomic _ (Cost c) _ (Progress p)) = Cost $ c * (1 - p) -- cost is weighted by remaining progress+cost (Sequence _ ps) = costConjunction ps+cost (Product _ ps) = costConjunction ps+cost (Sum _ ps) =    Cost $ sum $ map (\x -> (1 - snd x) * fst x) $ zip costs accTrusts  where-   costs = NE.toList $ (getCost . cost sys) <$> ps-   accTrusts = NE.toList $ NE.scanl (\a b -> a + b*(1-a)) 0 $ (getTrust . trust sys) <$> ps+   costs = NE.toList $ (getCost . cost) <$> ps+   accTrusts = NE.toList $ NE.scanl (\a b -> a + b*(1-a)) 0 $ (getTrust . trust) <$> ps+cost (Annotated _) = undefined -costConjunction ∷ ProjectSystem → NE.NonEmpty ProjectExpr → Cost-costConjunction sys ps =+costConjunction ∷ NE.NonEmpty ProjectExpr → Cost+costConjunction ps =    Cost $ sum $ zipWith (*) costs accTrusts   where-    costs = NE.toList $ (getCost . cost sys) <$> ps-    accTrusts = NE.toList $ product <$> NE.inits ((getTrust . trust sys) <$> ps)+    costs = NE.toList $ (getCost . cost) <$> ps+    accTrusts = NE.toList $ product <$> NE.inits ((getTrust . trust) <$> ps)  -- | Expected probability of succeeding-trust ∷ ProjectSystem → ProjectExpr → Trust-trust sys (Reference n) =-  case M.lookup n (bindings sys) of-    Just (BindingAtomic _ _ (Trust t) (Progress p)) -> Trust $ p + t * (1-p)-    Just (BindingExpr _ p)                          -> trust sys p -- TODO:10 avoid cyclic-    Nothing                                         -> defaultTrust -- mentioned but no props neither task defined-trust sys (Sequence ps) = trustConjunction sys ps-trust sys (Product ps) = trustConjunction sys ps-trust sys (Sum ps) =-  Trust $ foldl (\a b -> a + b*(1-a)) 0 $ (getTrust . trust sys) <$> ps+trust ∷ ProjectExpr → Trust+trust (Atomic _ _ (Trust t) (Progress p)) = Trust $ p + t * (1-p) -- reduced by progress+trust (Sequence _ ps) = trustConjunction ps+trust (Product _ ps) = trustConjunction ps+trust (Sum _ ps) =+  Trust $ foldl (\a b -> a + b*(1-a)) 0 $ (getTrust . trust) <$> ps+trust (Annotated _) = undefined -trustConjunction ∷ ProjectSystem → NE.NonEmpty ProjectExpr → Trust-trustConjunction sys ps = Trust $ product $ (getTrust . trust sys) <$> ps+trustConjunction ∷ NE.NonEmpty ProjectExpr → Trust+trustConjunction ps = Trust $ product $ (getTrust . trust) <$> 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:20 avoid cyclic-    Nothing                      -> defaultProgress -- mentioned but no props neither task defined-progress sys (Sequence ps)   = progressConjunction sys ps-progress sys (Product ps)    = progressConjunction sys ps-progress sys (Sum ps)        = maximum $ progress sys <$> ps+subprojects :: Project a -> [Project a]+subprojects (Sequence _ ps) = NE.toList ps+subprojects (Product _ ps)  = NE.toList ps+subprojects (Sum _ ps)      = NE.toList ps+subprojects _               = [] -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)+properties :: Project a -> Maybe ProjectProperties+properties (Annotated _)        = Nothing+properties (Product props _)    = Just props+properties (Sequence props _)   = Just props+properties (Sum props _)        = Just props+properties (Atomic props _ _ _) = Just props +progress ∷ ProjectExpr → Progress+progress (Atomic _ _ _ p) = p+progress (Sequence _ ps)  = progressConjunction ps+progress (Product _ ps)   = progressConjunction ps+progress (Sum _ ps)       = maximum $ progress <$> ps+progress (Annotated _)    = undefined++progressConjunction ∷ NE.NonEmpty ProjectExpr → Progress+progressConjunction ps = sum (progress <$> ps) / fromIntegral (length ps)+ -- |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+simplify ∷ Project a → Project a+simplify (Sum _ (p :| []))      = simplify p+simplify (Product _ (p :| []))  = simplify p+simplify (Sequence _ (p :| [])) = simplify p+simplify (Sum r ps) =+    Sum r $ (reduce . simplify) =<< ps   where-    reduce (Sum ps') = reduce =<< ps'-    reduce p         = [simplifyProj p]-simplifyProj (Product ps) =-    Product $ (reduce . simplifyProj) =<< ps+    reduce (Sum _ ps') = reduce =<< ps'+    reduce p           = [simplify p]+simplify (Product r ps) =+    Product r $ (reduce . simplify) =<< ps   where-    reduce (Product ps') = reduce =<< ps'-    reduce p             = [simplifyProj p]-simplifyProj (Sequence ps) =-    Sequence $ (reduce . simplifyProj) =<< ps+    reduce (Product _ ps') = reduce =<< ps'+    reduce p               = [simplify p]+simplify (Sequence r ps) =+    Sequence r $ (reduce . simplify) =<< 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+    reduce (Sequence _ ps') = reduce =<< ps'+    reduce p                = [simplify p]+simplify p = p  -- |Sort project in order that minimizes cost-prioritizeProj ∷ ProjectSystem → ProjectExpr → ProjectExpr-prioritizeProj sys (Sum ps)      =-  let f p = getCost (cost sys' p) / getTrust (trust sys' p)-      sys' = prioritizeSys sys-  in Sum $ NE.sortWith (nanToInf . f) $ prioritizeProj sys' <$> ps-prioritizeProj sys (Product ps)  =-  let f p = getCost (cost sys' p) / (1 - getTrust (trust sys' p))-      sys' = prioritizeSys sys-  in Product $ NE.sortWith (nanToInf . f) $ prioritizeProj sys' <$> ps-prioritizeProj sys (Sequence ps)  =-  Sequence $ prioritizeProj sys <$> ps-prioritizeProj _   p             = p+prioritize ∷ ProjectExpr → ProjectExpr+prioritize (Sum r ps)      =+  let f p = getCost (cost p) / getTrust (trust p)+  in Sum r $ NE.sortWith (nanToInf . f) $ prioritize <$> ps+prioritize (Product r ps)  =+  let f p = getCost (cost p) / (1 - getTrust (trust p))+  in Product r $ NE.sortWith (nanToInf . f) $ prioritize <$> ps+prioritize (Sequence r ps)  =+  Sequence r $ prioritize <$> ps+prioritize p        = p  -- |Helper function to transform any Nan (not a number) to positive infinity nanToInf :: RealFloat a => a -> a

@@ -8,41 +8,31 @@ Portability : POSIX -} {-# LANGUAGE UnicodeSyntax #-}-module MasterPlan.Internal.Debug ( debugSys , debugProj) where+module MasterPlan.Internal.Debug (printProject) where -import           Control.Monad   (forM_, replicateM_, void)-import qualified Data.Map        as M+import           Control.Monad   (forM_, replicateM_)+import           Data.Maybe      (fromMaybe) 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 $ getProjectKey key ++ " = "-                            case b of-                              BindingExpr _ e -> putStr "\n" >> debugProj sys e-                              BindingAtomic _ (Cost c) (Trust t) (Progress p) ->-                                putStrLn $ printf "(c:%.2f,t:%.2f,p:%2.f)" c t p- -- |Print a Project Expression in a Project System to standard output. -- The expression is printed in a tree like fashion.-debugProj ∷ ProjectSystem → ProjectExpr → IO ()-debugProj sys = print' 0+printProject ∷ ProjectExpr → IO ()+printProject = print' 0    where      ident ∷ Int → IO ()      ident il = replicateM_ il $ putStr " |"       print' ∷ Int → ProjectExpr → IO ()-     print' il p@(Reference (ProjectKey n))  = ident il >> putStr ("-" ++ n ++ "   ") >> ctp p-     print' il p@(Sum ps) = ident il >> putStr "-+   " >> ctp p >> forM_ ps (print' $ il+1)-     print' il p@(Sequence ps) = ident il >> putStr "->   " >> ctp p >> forM_ ps (print' $ il+1)-     print' il p@(Product ps) = ident il >> putStr "-*   " >> ctp p >> forM_ ps (print' $ il+1)+     print' il p@(Atomic r _ _ _)  = ident il >> putStr ("-" ++ fromMaybe "?" (title r) ++ "   ") >> 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)+     print' _  (Annotated _ ) = undefined       ctp p = putStrLn $ printf " c=%.2f  t=%.2f  p=%.2f"-                               (getCost $ cost sys p)-                               (getTrust $ trust sys p)-                               (getProgress $ progress sys p)+                               (getCost $ cost p)+                               (getTrust $ trust p)+                               (getProgress $ progress p)

@@ -10,13 +10,10 @@ {-# LANGUAGE OverloadedLists   #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UnicodeSyntax     #-}-module MasterPlan.Parser (runParser) where+module MasterPlan.Parser (ProjectKey, runParser) where  import           Control.Monad.State-import           Data.Generics-import           Data.List                  (nub) import qualified Data.List.NonEmpty         as NE-import qualified Data.Map                   as M import           Data.Maybe                 (fromMaybe, isJust) import qualified Data.Text                  as T import           Data.Void@@ -50,8 +47,8 @@ identifier ∷ Parser String identifier = (lexeme . try) $ (:) <$> letterChar <*> many alphaNumChar -projectKey :: Parser ProjectKey-projectKey = ProjectKey <$> (identifier >>= check) <?> "project key"+projectKey :: Parser String+projectKey = (identifier >>= check) <?> "project key"   where     check x       | x `elem` rws = fail $ "keyword " ++ show x ++ " cannot be an identifier"@@ -69,31 +66,31 @@ nonNegativeNumber :: Parser Float nonNegativeNumber = L.float -expression ∷ Parser ProjectExpr-expression =-    simplifyProj <$> makeExprParser term table <?> "expression"+-- |Parses the part of right-hand-side after the optional properties+--  (literal string title or properties between curly brackets)+expression ∷ ProjectProperties -> Parser (Project ProjectKey)+expression props =+    simplify <$> makeExprParser term table <?> "expression"   where-    term = parens expression <|> (Reference <$> projectKey)+    term =  parens (expression defaultProjectProps) <|> (Annotated <$> projectKey)     table = [[binary "*" (combineWith Product)]             ,[binary "->" (combineWith Sequence)]             ,[binary "+" (combineWith Sum)]]-    binary  op f = InfixL  (f <$ symbol op)--    combineWith :: (NE.NonEmpty ProjectExpr -> ProjectExpr) -> ProjectExpr -> ProjectExpr -> ProjectExpr-    combineWith c p1 p2 = c $ p1 NE.<| [p2]+    binary  op f = InfixL (f <$ symbol op) +    combineWith c p1 p2 = c props $ p1 NE.<| [p2] -binding :: ProjectKey -> Parser Binding---binding key = do (props, mc, mt, mp) <- bracketAttributes+-- |Parses the entire right-hand-side of definitions+binding :: ProjectKey -> Parser (Project ProjectKey) binding key = do (props, mc, mt, mp) <- try simpleTitle <|> try bracketAttributes <|> noAttributes                  case (mc, mt, mp) of                   (Nothing, Nothing, Nothing) ->-                     try (BindingExpr props <$> (sc *> optional (symbol "=") *> expression)) <|>-                       pure (BindingAtomic props defaultCost defaultTrust defaultProgress)-                  (mc', mt', mp') -> pure $ BindingAtomic props-                                                         (fromMaybe defaultCost mc')-                                                         (fromMaybe defaultTrust mt')-                                                         (fromMaybe defaultProgress mp')+                     try (sc *> optional (symbol "=") *> expression props) <|>+                       pure (Atomic props defaultCost defaultTrust defaultProgress)+                  (mc', mt', mp') -> pure $ Atomic props+                                                   (fromMaybe defaultCost mc')+                                                   (fromMaybe defaultTrust mt')+                                                   (fromMaybe defaultProgress mp')  where    attrKey :: Parser ProjAttribute    attrKey = do n <- identifier <?> "attribute name"@@ -103,11 +100,11 @@     simpleTitle, bracketAttributes, noAttributes :: Parser (ProjectProperties, Maybe Cost, Maybe Trust, Maybe Progress)    simpleTitle = do s <- stringLiteral <?> "title"-                    pure (defaultProjectProps {title=s}, Nothing, Nothing, Nothing)+                    pure (defaultProjectProps {title= Just s}, Nothing, Nothing, Nothing) -   bracketAttributes = symbol "{" *> attributes (defaultProjectProps {title=getProjectKey key}) Nothing Nothing Nothing+   bracketAttributes = symbol "{" *> attributes (defaultProjectProps {title=Just key}) Nothing Nothing Nothing -   noAttributes = pure (defaultProjectProps {title=getProjectKey key}, Nothing, Nothing, Nothing)+   noAttributes = pure (defaultProjectProps {title=Just key}, Nothing, Nothing, Nothing)     attributes :: ProjectProperties -> Maybe Cost -> Maybe Trust -> Maybe Progress               -> Parser (ProjectProperties, Maybe Cost, Maybe Trust, Maybe Progress)@@ -116,7 +113,7 @@          do attr <- sc *> attrKey             case attr of               PTitle -> do s <- stringLiteral <?> "title"-                           attributes (props {title=s}) mc mt mp+                           attributes (props {title=Just s}) mc mt mp               PDescription -> do when (isJust $ description props) $ fail "redefinition of description"                                  s <- stringLiteral <?> "description"                                  attributes (props {description=Just s}) mc mt mp@@ -137,31 +134,49 @@                               attributes props mc mt (Just p)  --- find out all the names that a particular binding references-dependencies ∷ ProjectSystem -> Binding → [ProjectKey]-dependencies sys = everything (++) ([] `mkQ` collectDep)-  where-    collectDep (Reference n) = nub $ n : everything (++) ([] `mkQ` collectDep) (M.lookup n $ bindings sys)-    collectDep _ = []--projectSystem :: Parser ProjectSystem-projectSystem =-    mkProjSystem <$> definitions []+-- |Parses the entire plan file, given the name of the "root" project.+--  returns this project+plan :: Bool -- ^ strict mode: fails if a reference has no definition+     -> ProjectKey -- ^ the name of the root project+     -> Parser ProjectExpr+plan strictMode root =+    do bindings <- definitions []+       case lookup root bindings of+         Nothing -> fail $ "root project \"" ++ root ++ "\" is undefined"+         Just p  -> resolveReferences bindings [root] p  where-   mkProjSystem = ProjectSystem . M.fromList +   -- definitions will parse into a list of tuples: (key, Project ProjectKey)+   definitions :: [(ProjectKey, Project ProjectKey)] -> Parser [(ProjectKey, Project ProjectKey)]    definitions ds = do key <- sc *> projectKey-                       when (key `elem` map fst ds) $ fail $ "redefinition of \"" ++ getProjectKey key ++ "\""+                       when (key `elem` map fst ds) $ fail $ "redefinition of \"" ++ key ++ "\""                        b <- binding key <* symbol ";"--                       -- check if it's recursive-                       let deps = dependencies (mkProjSystem ds) b-                       when (key `elem` deps) $ fail $ "definition of \"" ++ getProjectKey key ++ "\" is recursive"-                        let ds' = (key,b):ds                        (try eof *> pure ds') <|> definitions ds' -runParser :: FilePath -> T.Text -> Either String ProjectSystem-runParser filename contents = case parse projectSystem filename contents of-                                Left e -> Left $ parseErrorPretty' contents e-                                Right v -> Right v+   resolveReferences :: [(ProjectKey, Project ProjectKey)]+                     -> [ProjectKey]+                     -> Project ProjectKey+                     -> Parser ProjectExpr+   resolveReferences bs ks (Sum r ps) = Sum r <$> mapM (resolveReferences bs ks) ps+   resolveReferences bs ks (Sequence r ps) = Sequence r <$> mapM (resolveReferences bs ks) ps+   resolveReferences bs ks (Product r ps) = Product r <$> mapM (resolveReferences bs ks) ps+   resolveReferences bs ks (Annotated k)+      | k `elem` ks  = fail $ "definition of \"" ++ k ++ "\" is recursive"+      | otherwise = case lookup k bs of+                      Nothing+                       | strictMode -> fail $ "project \"" ++ k ++ "\" is undefined"+                       | otherwise -> pure $ Atomic defaultProjectProps {title=Just k}+                                                    defaultCost defaultTrust defaultProgress+                      Just p  -> resolveReferences bs (k:ks) p+   resolveReferences _ _ (Atomic r c t p) = pure $ Atomic r c t p++runParser :: Bool -- ^ strict mode: fails if a reference has no definition+          -> FilePath -- ^ the file name to use in error messages+          -> T.Text -- ^ contents of the plan to parse+          -> ProjectKey -- ^ the name of the root project+          -> Either String ProjectExpr+runParser strictMode filename contents root =+  case parse (plan strictMode root) filename contents of+      Left e  -> Left $ parseErrorPretty' contents e+      Right v -> Right v

@@ -2,9 +2,7 @@ {-# 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@@ -14,54 +12,29 @@    arbitrary =       let s = getASCIIString <$> arbitrary-          os = oneof [pure Nothing, Just <$> s]-      in ProjectProperties <$> s <*> os <*> os <*> os+          maybeStr x = if null x then Nothing else Just x+          os = oneof [pure Nothing, maybeStr <$> s]+          titleG = Just <$> elements [[x] | x <- ['a'..'z']]+      in ProjectProperties <$> titleG <*> os <*> os <*> os    shrink p = (if isNothing (description p) then [] else [p { description = Nothing }]) ++              (if isNothing (url p) then [] else [p { url = Nothing }]) ++              (if isNothing (owner p) then [] else [p { owner = Nothing }]) -testingKeys ∷ [ProjectKey]-testingKeys = ["a", "b", "c", "d"]--instance Arbitrary ProjectSystem where--  arbitrary = do bs <- replicateM (length testingKeys) arbitrary-                 rootB <- BindingExpr <$> arbitrary <*> arbitrary-                 pure $ ProjectSystem $ M.insert "root" rootB $ M.fromList $ zip testingKeys bs--  shrink (ProjectSystem bs) =-      map ProjectSystem $ concatMap shrinkOne testingKeys-    where-      shrinkOne ∷ ProjectKey → [M.Map ProjectKey Binding]-      shrinkOne k = case M.lookup k bs of-        Nothing -> []-        Just b  -> map (\s -> M.adjust (const s) k bs) $ shrink b--instance Arbitrary Binding where--  -- NOTE: Binding arbitrary are always tasks (no expression)-  --       to avoid generating cycles-  arbitrary =-    let unitGen = elements [0.0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1.0]-     in BindingAtomic <$> arbitrary-                      <*> (Cost <$> elements [0, 1 .. 100])-                      <*> (Trust <$> unitGen)-                      <*> (Progress <$> unitGen)--  shrink (BindingExpr pr e) = map (BindingExpr pr) $ shrink e-  shrink _                  = []--instance Arbitrary ProjectExpr where+instance Arbitrary (Project a) 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) ]+        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 [ (1, Sum defaultProjectProps <$> scale shrinkFactor arbitrary)+                  , (1, Product defaultProjectProps <$> scale shrinkFactor arbitrary)+                  , (1, Sequence defaultProjectProps <$> scale shrinkFactor arbitrary)+                  , (2, Atomic <$> arbitrary+                               <*> (Cost <$> elements [0, 1 .. 100])+                               <*> (Trust <$> unitGen)+                               <*> (Progress <$> unitGen)) ] -  shrink (Sum ps)      = NE.toList ps-  shrink (Product ps)  = NE.toList ps-  shrink (Sequence ps) = NE.toList ps-  shrink (Reference _) = []+  shrink (Sum _ ps)      = NE.toList ps+  shrink (Product _ ps)  = NE.toList ps+  shrink (Sequence _ ps) = NE.toList ps+  shrink _               = []

@@ -5,8 +5,6 @@ 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@@ -19,26 +17,23 @@ -- It's a stateful computation with the random generator, which computes -- a 2-tuple with a Boolean: whether the execution was successful (A Bernoulli -- sample from trust), and the total actual cost incurred.-simulate ∷ RandomGen g ⇒ ProjectSystem → ProjectExpr → State g (Bool, Cost)-simulate sys (Reference n) =-   case M.lookup n (bindings sys) of-     Just (BindingAtomic _ (Cost c) (Trust t) (Progress p)) ->-       do r <- state $ randomR (0, 1)-          let remainingProgress =  1 - p-              effectiveTrust = p + t * remainingProgress-              effectiveCost = c * remainingProgress-          pure (effectiveTrust > r, Cost effectiveCost)-     Just (BindingExpr _ p)       -> simulate sys p -- TODO:30 avoid cyclic-     Nothing                      -> pure (True, defaultCost)+simulate ∷ RandomGen g ⇒ Project a → State g (Bool, Cost)+simulate (Atomic _ (Cost c) (Trust t) (Progress p)) =+   do r <- state $ randomR (0, 1)+      let remainingProgress =  1 - p+          effectiveTrust = p + t * remainingProgress+          effectiveCost = c * remainingProgress+      pure (effectiveTrust > r, Cost effectiveCost) -simulate sys (Sequence ps)   = simulateConjunction sys $ NE.toList ps-simulate sys (Product ps)    = simulateConjunction sys $ NE.toList ps-simulate sys (Sum ps)        =+simulate (Annotated _)     = pure (True, 0)+simulate (Sequence _ ps)   = simulateConjunction $ NE.toList ps+simulate (Product _ ps)    = simulateConjunction $ NE.toList ps+simulate (Sum _ ps)        =   simulate' $ NE.toList ps  where-   simulate' ∷ RandomGen g ⇒ [ProjectExpr] → State g (Bool, Cost)+   simulate' ∷ RandomGen g ⇒ [Project a] → State g (Bool, Cost)    simulate' [] = pure (False, 0)-   simulate' (p:rest) = do (success, c) <- simulate sys p+   simulate' (p:rest) = do (success, c) <- simulate p                            if success then                              pure (True, c)                            else@@ -48,23 +43,23 @@ -- |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)+simulateConjunction ∷ RandomGen g ⇒ [Project a] → State g (Bool, Cost)+simulateConjunction []       = pure (True, 0)+simulateConjunction (p:rest) = do (success, c) <- simulate p+                                  if success then do+                                    (success', c') <- simulateConjunction 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)+monteCarloTrustAndCost ∷ RandomGen g ⇒ Int → ProjectExpr → State g (Trust, Cost)+monteCarloTrustAndCost n p = do results <- replicateM n $ simulate p+                                let trusts = map (bool 0 1 . fst) results+                                    costs  = map snd results+                                pure (sum trusts / fromIntegral n,+                                      sum costs / fromIntegral n)  aproximatelyEqual ∷ (Show a, Real a, Fractional a) => a -> a -> a → a -> Property aproximatelyEqual alpha beta x y =@@ -83,13 +78,12 @@         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)+        let monteCarloAndAnalyticalMustAgree ∷ ProjectExpr -> Property+            monteCarloAndAnalyticalMustAgree p =+                counterexample "disagree on cost"  (cost'  `eq` cost  p) .&&.+                counterexample "disagree on trust" (trust' `eq` trust p)               where-                (trust', cost') = evalState (monteCarloTrustAndCost 50000 sys p) g+                (trust', cost') = evalState (monteCarloTrustAndCost 50000 p) g         monteCarloAndAnalyticalMustAgree    describe "simplification" $ do@@ -100,31 +94,30 @@     prop "is irreductible" $ do         let simplificationIsIrreductible :: ProjectExpr -> Property             simplificationIsIrreductible p =-                let p' = simplifyProj p-                    p'' = simplifyProj p'+                let p' = simplify p+                    p'' = simplify 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+      let simplifyIsStable :: ProjectExpr -> Property+          simplifyIsStable p =+            let p' = simplify p+             in cost p `eq` cost p' .&&. trust p `eq` trust p'        simplifyIsStable    describe "prioritization" $ do -    let shuffleProjs :: NE.NonEmpty ProjectExpr -> IO (NE.NonEmpty ProjectExpr)+    let shuffleProjs :: NE.NonEmpty (Project a) -> IO (NE.NonEmpty (Project a))         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+        shuffleProj :: Project a -> IO (Project a)+        shuffleProj (Sum r ps)     = Sum r <$> shuffleProjs ps+        shuffleProj (Product r ps) = Product r <$> shuffleProjs ps+        shuffleProj p              = pure p      prop "minimize cost and keep trust stable" $ do       -- This test verifies that for any arbitrary project tree, the@@ -132,15 +125,14 @@        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+      let prioritizeMinimizesCost :: ProjectExpr -> Property+          prioritizeMinimizesCost p =+            let op = prioritize p+                ocost = cost op+                otrust = trust op                 costIsLessOrEqual p' =-                  counterexample ("variation has smaller cost: " ++ show p') $ ocost <= cost sys p'-                trustIsSame p' = otrust `eq` trust sys p'+                  counterexample ("variation has smaller cost: " ++ show p') $ ocost <= cost p'+                trustIsSame p' = otrust `eq` trust p'             in ioProperty $ do variations <- replicateM 10 (shuffleProj p)                                return $ conjoin (map costIsLessOrEqual variations) .&.                                         conjoin (map trustIsSame variations)

@@ -3,8 +3,6 @@ module MasterPlan.ParserSpec (spec) where  import           Data.Either                 (isRight)-import qualified Data.Map                    as M-import           Data.Maybe                  (fromJust) import           Data.Monoid                 ((<>)) import qualified Data.Text                   as T import           MasterPlan.Arbitrary        ()@@ -21,44 +19,48 @@      let allProps = [minBound :: ProjAttribute ..] +    let asRoot (Atomic r c t p) = Atomic r {title=Just "root"} c t p+        asRoot (Sum r ps)       = Sum r {title=Just "root"} ps+        asRoot (Sequence r ps)  = Sequence r {title=Just "root"} ps+        asRoot (Product r ps)   = Product r {title=Just "root"} ps+        asRoot p                = p+     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)+      let renderedIsParseable ∷ ProjectExpr → Property+          renderedIsParseable p =+            let p' = simplify p+                rendered = render p' allProps+             in counterexample (T.unpack rendered) $ isRight (runParser False "test1" rendered "root")        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'+      let propertyParseAndOutputIdentity ∷ ProjectExpr → Property+          propertyParseAndOutputIdentity p =+            let p' = asRoot $ simplify p+                parsed = runParser False "test2" (render p' allProps) "root"+             in isRight parsed ==> parsed === Right p'        withMaxSuccess 50 propertyParseAndOutputIdentity      it "should parse without prioritization" $ do -      let input = "root = a + b;\+      let input = "main = a + b;\                   \a = x + y;\                   \b { cost 9 };\                   \x { cost 10 };\                   \y { cost 5 trust 90% };" -      let (Right sys) = runParser "test" input--      let (BindingExpr _ root) = fromJust $ M.lookup "root" (bindings sys)+      let (Right p) = runParser True "test" input "main" -      cost sys root `shouldBe` 10.0+      cost p `shouldBe` 10.0        -- now prioritize... a little out of scope for this test, but fine: -      let sys' = prioritizeSys sys-      let (BindingExpr _ root') = fromJust $ M.lookup "root" (bindings sys')+      let p' = prioritize p -      cost sys' root' `shouldBe` 6.0+      cost p' `shouldBe` 6.0      it "should reject recursive equations" $ do @@ -72,22 +74,22 @@       -- obvious       let program1 = wrap ["root = a + b + root"] -      runParser "recursive1" program1 `shouldSatisfy` expectedError "root"+      runParser False "recursive1" program1 "root" `shouldSatisfy` expectedError "root"        let program2 = wrap [ "root = a + b"                           , "a = x * root" ] -      runParser "recursive2" program2 `shouldSatisfy` expectedError "a"+      runParser False "recursive2" program2 "root" `shouldSatisfy` expectedError "root" -      let program3 = wrap [ "root = x + y"+      let program3 = wrap [ "xxx = x + a"                           , "a = b * c"                           , "c = d -> a" ] -      runParser "recursive3" program3 `shouldSatisfy` expectedError "c"+      runParser False "recursive3" program3 "xxx" `shouldSatisfy` expectedError "a" -      let program4 = wrap [ "root = a + y"-                          , "d = x + root"+      let program4 = wrap [ "yyy = a + y"+                          , "d = x + yyy"                           , "a = b * c"                           , "c = d -> e" ] -      runParser "recursive4" program4 `shouldSatisfy` expectedError "c"+      runParser False "recursive4" program4 "yyy" `shouldSatisfy` expectedError "yyy"