diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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' diff --git a/master-plan.cabal b/master-plan.cabal --- a/master-plan.cabal +++ b/master-plan.cabal @@ -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 diff --git a/src/MasterPlan/Backend/Graph.hs b/src/MasterPlan/Backend/Graph.hs --- a/src/MasterPlan/Backend/Graph.hs +++ b/src/MasterPlan/Backend/Graph.hs @@ -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)) diff --git a/src/MasterPlan/Backend/Identity.hs b/src/MasterPlan/Backend/Identity.hs --- a/src/MasterPlan/Backend/Identity.hs +++ b/src/MasterPlan/Backend/Identity.hs @@ -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 _ = [] diff --git a/src/MasterPlan/Data.hs b/src/MasterPlan/Data.hs --- a/src/MasterPlan/Data.hs +++ b/src/MasterPlan/Data.hs @@ -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 diff --git a/src/MasterPlan/Internal/Debug.hs b/src/MasterPlan/Internal/Debug.hs --- a/src/MasterPlan/Internal/Debug.hs +++ b/src/MasterPlan/Internal/Debug.hs @@ -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) diff --git a/src/MasterPlan/Parser.hs b/src/MasterPlan/Parser.hs --- a/src/MasterPlan/Parser.hs +++ b/src/MasterPlan/Parser.hs @@ -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 diff --git a/test/MasterPlan/Arbitrary.hs b/test/MasterPlan/Arbitrary.hs --- a/test/MasterPlan/Arbitrary.hs +++ b/test/MasterPlan/Arbitrary.hs @@ -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 _ = [] diff --git a/test/MasterPlan/DataSpec.hs b/test/MasterPlan/DataSpec.hs --- a/test/MasterPlan/DataSpec.hs +++ b/test/MasterPlan/DataSpec.hs @@ -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) diff --git a/test/MasterPlan/ParserSpec.hs b/test/MasterPlan/ParserSpec.hs --- a/test/MasterPlan/ParserSpec.hs +++ b/test/MasterPlan/ParserSpec.hs @@ -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"