mirror of
https://github.com/rodrigosetti/master-plan.git
synced 2024-11-21 17:13:41 +03:00
Refactor: using newtypes
This commit is contained in:
Rodrigo Setti
parent
dd4f8bf6f9
commit
73baeba40b
@ -7,13 +7,13 @@
|
||||
steps:
|
||||
# Convert some ASCII sequences to their Unicode equivalents. This is disabled
|
||||
# by default.
|
||||
- unicode_syntax:
|
||||
# In order to make this work, we also need to insert the UnicodeSyntax
|
||||
# language pragma. If this flag is set to true, we insert it when it's
|
||||
# not already present. You may want to disable it if you configure
|
||||
# language extensions using some other method than pragmas. Default:
|
||||
# true.
|
||||
add_language_pragma: true
|
||||
#- unicode_syntax:
|
||||
# # In order to make this work, we also need to insert the UnicodeSyntax
|
||||
# # language pragma. If this flag is set to true, we insert it when it's
|
||||
# # not already present. You may want to disable it if you configure
|
||||
# # language extensions using some other method than pragmas. Default:
|
||||
# # true.
|
||||
# add_language_pragma: true
|
||||
|
||||
# Align the right hand side of some elements. This is quite conservative
|
||||
# and only applies to statements where each element occupies a single
|
||||
|
||||
20
app/Main.hs
20
app/Main.hs
@ -64,12 +64,12 @@ cmdParser = Opts <$> optional (strArgument ( help "plan file to read from (defau
|
||||
<> help "height of the output image"
|
||||
<> value (-1)
|
||||
<> metavar "NUMBER")
|
||||
<*> strOption ( long "root"
|
||||
<> short 'r'
|
||||
<> help "name of the root project definition"
|
||||
<> value "root"
|
||||
<> showDefault
|
||||
<> metavar "NAME")
|
||||
<*> (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))))
|
||||
@ -80,9 +80,9 @@ cmdParser = Opts <$> optional (strArgument ( help "plan file to read from (defau
|
||||
invertProps l = filter (`notElem` l) $ map snd propertyNames
|
||||
|
||||
filterParser ∷ Parser ProjFilter
|
||||
filterParser = (ProjFilter . mkProgressFilter) <$> option auto ( long "progress-below"
|
||||
<> help "only display projects which progress is < N%"
|
||||
<> metavar "N" )
|
||||
filterParser = (ProjFilter . 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
|
||||
|
||||
@ -100,7 +100,7 @@ filterBinding sys (ProjFilter f) (BindingExpr r e) = BindingExpr r <$> filterPro
|
||||
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
|
||||
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)
|
||||
|
||||
@ -7,25 +7,26 @@ Maintainer : rodrigosetti@gmail.com
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
-}
|
||||
{-# LANGUAGE UnicodeSyntax #-}
|
||||
{-# LANGUAGE NoMonomorphismRestriction #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NoMonomorphismRestriction #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UnicodeSyntax #-}
|
||||
module MasterPlan.Backend.Graph (render, RenderOptions(..)) where
|
||||
|
||||
import MasterPlan.Data
|
||||
import Diagrams.Prelude hiding (render, Product, Sum)
|
||||
import Diagrams.Backend.Rasterific
|
||||
import Data.List (intersperse)
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Monad.State
|
||||
import qualified Data.Map as M
|
||||
import Data.List (intersperse)
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (catMaybes, fromMaybe)
|
||||
import Data.Tree
|
||||
import Data.Maybe (fromMaybe, catMaybes)
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Text.Printf (printf)
|
||||
import Diagrams.TwoD.Text (Text)
|
||||
import Diagrams.Backend.Rasterific
|
||||
import Diagrams.Prelude hiding (Product, Sum, render)
|
||||
import Diagrams.TwoD.Text (Text)
|
||||
import MasterPlan.Data
|
||||
import Text.Printf (printf)
|
||||
|
||||
-- text :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any
|
||||
-- text = texterific
|
||||
@ -57,7 +58,7 @@ mkLeaf a = Node (AtomicNode, a) []
|
||||
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
|
||||
Just b -> Just <$> bindingToRM rootK b
|
||||
where
|
||||
bindingToRM :: ProjectKey -> Binding -> State [ProjectKey] RenderModel
|
||||
bindingToRM key (BindingExpr prop p) = projToRM p (Just key) (Just prop)
|
||||
@ -83,10 +84,10 @@ toRenderModel sys rootK = case M.lookup rootK (bindings sys) of
|
||||
projToRM p@(Product ps) = mkNode (\x -> Node (ProductNode, x)) p ps
|
||||
projToRM (Reference n) =
|
||||
\k p -> case M.lookup n $ bindings sys of
|
||||
Nothing -> pure $ Node (AtomicNode, PNode k (p <|> pure defaultProjectProps {title=n}) defaultCost defaultTrust defaultProgress) []
|
||||
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 $ bindingTitle b) []
|
||||
then pure $ Node (AtomicNode, NodeRef $ ProjectKey $ bindingTitle b) []
|
||||
else modify (n:) >> bindingToRM n b
|
||||
|
||||
-- |how many children
|
||||
@ -95,17 +96,17 @@ treeSize (Node _ []) = 1
|
||||
treeSize (Node _ ts) = sum $ treeSize <$> ts
|
||||
|
||||
-- |Options for rendering
|
||||
data RenderOptions = RenderOptions { colorByProgress :: Bool -- ^Whether to color boxes depending on progress
|
||||
, renderWidth :: Integer -- ^The width of the output image
|
||||
, renderHeight :: Integer -- ^The height of the output image
|
||||
, rootKey :: ProjectKey -- ^The name of the root project
|
||||
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
|
||||
} deriving (Eq, Show)
|
||||
|
||||
-- | The main rendering function
|
||||
render ∷ FilePath -> RenderOptions-> ProjectSystem → IO ()
|
||||
render fp (RenderOptions colorByP w h rootK props) sys =
|
||||
let noRootEroor = text $ "no project named \"" ++ rootK ++ "\" found."
|
||||
let noRootEroor = text $ "no project named \"" ++ getProjectKey rootK ++ "\" found."
|
||||
dia = fromMaybe noRootEroor $ renderTree colorByP props <$> evalState (toRenderModel sys rootK) []
|
||||
in renderRasterific fp (dims2D (fromInteger w) (fromInteger h)) $ bgFrame 1 white $ centerXY dia
|
||||
|
||||
@ -129,14 +130,14 @@ renderTree colorByP props x@(Node (ty, n) ts@(t:_)) =
|
||||
|
||||
typeSymbol =
|
||||
let txt = case ty of
|
||||
SumNode -> text "+"
|
||||
ProductNode -> text "x"
|
||||
SumNode -> text "+"
|
||||
ProductNode -> text "x"
|
||||
SequenceNode -> text "->"
|
||||
AtomicNode -> mempty
|
||||
AtomicNode -> mempty
|
||||
in txt # fontSizeL 2 # bold <> circle 2 # fc white # lwO 1
|
||||
|
||||
renderNode :: Bool -> [ProjAttribute] -> PNode -> QDiagram B V2 Double Any
|
||||
renderNode _ _ (NodeRef n) =
|
||||
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 # withEnvelope (rect 30 12 :: D V2 Double)
|
||||
@ -179,7 +180,7 @@ renderNode colorByP props (PNode _ prop c t p) =
|
||||
|
||||
displayCost c'
|
||||
| c' == 0 = mempty
|
||||
| otherwise = rightText $ "(" ++ printf "%.1f" c' ++ ")"
|
||||
| otherwise = rightText $ "(" ++ printf "%.1f" (getCost c') ++ ")"
|
||||
displayProgress p'
|
||||
| p' == 0 = mempty
|
||||
| p' == 1 = leftText "done"
|
||||
|
||||
@ -7,19 +7,19 @@ Maintainer : rodrigosetti@gmail.com
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
-}
|
||||
{-# LANGUAGE UnicodeSyntax #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE UnicodeSyntax #-}
|
||||
module MasterPlan.Backend.Identity (render) where
|
||||
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.RWS (RWS, evalRWS, gets, tell, modify)
|
||||
import Control.Monad.RWS (RWS, evalRWS, gets, modify, tell)
|
||||
import Data.Generics
|
||||
import Data.List (nub)
|
||||
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 Data.Maybe (isJust)
|
||||
import MasterPlan.Data
|
||||
|
||||
-- |Plain text renderer
|
||||
@ -29,14 +29,14 @@ render (ProjectSystem bs) whitelist =
|
||||
where
|
||||
renderRest = gets M.keys >>= mapM_ renderName
|
||||
|
||||
type RenderMonad = RWS [ProjAttribute] T.Text (M.Map String Binding)
|
||||
type RenderMonad = RWS [ProjAttribute] T.Text (M.Map ProjectKey Binding)
|
||||
|
||||
renderName ∷ ProjectKey → RenderMonad ()
|
||||
renderName projName =
|
||||
do mb <- gets $ M.lookup projName
|
||||
case mb of
|
||||
Nothing -> pure ()
|
||||
Just b -> do tell $ T.pack projName
|
||||
Just b -> do tell $ T.pack $ getProjectKey projName
|
||||
when (hasAttribute b) $ do
|
||||
tell " {\n"
|
||||
renderAttr b
|
||||
@ -52,7 +52,7 @@ renderName projName =
|
||||
|| c /= defaultCost
|
||||
|| t /= defaultTrust
|
||||
|| p /= defaultProgress
|
||||
hasProperty props = title props /= projName
|
||||
hasProperty props = title props /= getProjectKey projName
|
||||
|| isJust (description props)
|
||||
|| isJust (owner props)
|
||||
|| isJust (url props)
|
||||
@ -62,14 +62,15 @@ renderName projName =
|
||||
renderAttr (BindingExpr props _) = renderProps props
|
||||
renderAttr (BindingAtomic props c t p) =
|
||||
do renderProps props
|
||||
when (c /= defaultCost) $ tell $ "cost " <> T.pack (show c) <> "\n"
|
||||
when (t /= defaultTrust) $ tell $ "trust " <> percentage t <> "\n"
|
||||
when (p /= defaultProgress) $ tell $ "progress " <> percentage p <> "\n"
|
||||
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 /= projName) $ tell $ "title " <> T.pack (show $ title p) <> "\n"
|
||||
when (title p /= getProjectKey projName) $
|
||||
tell $ "title " <> T.pack (show $ title p) <> "\n"
|
||||
maybeRender "description" (description p)
|
||||
maybeRender "url" (url p)
|
||||
maybeRender "owner" (owner p)
|
||||
@ -79,13 +80,13 @@ renderName projName =
|
||||
in if parens && length ps > 1 then "(" <> s <> ")" else s
|
||||
|
||||
expressionToStr :: Bool -> ProjectExpr -> T.Text
|
||||
expressionToStr _ (Reference n) = T.pack n
|
||||
expressionToStr parens (Product ps) = combinedEToStr parens "*" ps
|
||||
expressionToStr parens (Sequence ps) = combinedEToStr parens "->" ps
|
||||
expressionToStr parens (Sum ps) = combinedEToStr parens "+" ps
|
||||
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 _ = []
|
||||
collectDep _ = []
|
||||
|
||||
@ -9,16 +9,18 @@ Portability : POSIX
|
||||
-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE UnicodeSyntax #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
module MasterPlan.Data ( ProjectExpr(..)
|
||||
, ProjectProperties(..)
|
||||
, ProjectSystem(..)
|
||||
, Binding(..)
|
||||
, ProjectKey
|
||||
, ProjectKey(..)
|
||||
, ProjAttribute(..)
|
||||
, Trust
|
||||
, Cost
|
||||
, Progress
|
||||
, Trust(..)
|
||||
, Cost(..)
|
||||
, Progress(..)
|
||||
, defaultProjectProps
|
||||
, defaultCost
|
||||
, defaultTrust
|
||||
@ -37,13 +39,19 @@ 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)
|
||||
|
||||
-- * Types
|
||||
|
||||
type Trust = Float
|
||||
type Cost = Float
|
||||
type Progress = Float
|
||||
type ProjectKey = String
|
||||
newtype Trust = Trust { getTrust :: Float }
|
||||
deriving (Show, Eq, Data, Ord, Num, Real, RealFrac, Fractional)
|
||||
newtype Cost = Cost { getCost :: Float }
|
||||
deriving (Show, Eq, Data, Ord, Num, Real, RealFrac, Fractional)
|
||||
newtype Progress = Progress { getProgress :: Float }
|
||||
deriving (Show, Eq, Data, Ord, Num, Real, RealFrac, Fractional)
|
||||
|
||||
newtype ProjectKey = ProjectKey { getProjectKey :: String }
|
||||
deriving (Show, Eq, Data, Ord, IsString)
|
||||
|
||||
-- |Structure of a project expression
|
||||
data ProjectExpr = Sum (NE.NonEmpty ProjectExpr)
|
||||
@ -109,38 +117,38 @@ bindingTitle (BindingExpr ProjectProperties { title=t} _) = t
|
||||
cost ∷ ProjectSystem → ProjectExpr → Cost
|
||||
cost sys (Reference n) =
|
||||
case M.lookup n (bindings sys) of
|
||||
Just (BindingAtomic _ c _ p) -> c * (1-p) -- cost is weighted by remaining progress
|
||||
Just (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) =
|
||||
sum $ map (\x -> (1 - snd x) * fst x) $ zip costs accTrusts
|
||||
Cost $ sum $ map (\x -> (1 - snd x) * fst x) $ zip costs accTrusts
|
||||
where
|
||||
accTrusts = NE.toList $ NE.scanl (\a b -> a + b*(1-a)) 0 $ trust sys <$> ps
|
||||
costs = NE.toList $ cost sys <$> ps
|
||||
costs = NE.toList $ (getCost . cost sys) <$> ps
|
||||
accTrusts = NE.toList $ NE.scanl (\a b -> a + b*(1-a)) 0 $ (getTrust . trust sys) <$> ps
|
||||
|
||||
costConjunction ∷ ProjectSystem → NE.NonEmpty ProjectExpr → Cost
|
||||
costConjunction sys ps =
|
||||
sum $ zipWith (*) costs accTrusts
|
||||
Cost $ sum $ zipWith (*) costs accTrusts
|
||||
where
|
||||
costs = NE.toList $ cost sys <$> ps
|
||||
accTrusts = NE.toList $ product <$> NE.inits (trust sys <$> ps)
|
||||
costs = NE.toList $ (getCost . cost sys) <$> ps
|
||||
accTrusts = NE.toList $ product <$> NE.inits ((getTrust . trust sys) <$> ps)
|
||||
|
||||
-- | Expected probability of succeeding
|
||||
trust ∷ ProjectSystem → ProjectExpr → Trust
|
||||
trust sys (Reference n) =
|
||||
case M.lookup n (bindings sys) of
|
||||
Just (BindingAtomic _ _ t p) -> p + t * (1-p)
|
||||
Just (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) =
|
||||
foldl (\a b -> a + b*(1-a)) 0 $ trust sys <$> ps
|
||||
Trust $ foldl (\a b -> a + b*(1-a)) 0 $ (getTrust . trust sys) <$> ps
|
||||
|
||||
trustConjunction ∷ ProjectSystem → NE.NonEmpty ProjectExpr → Trust
|
||||
trustConjunction sys ps = product $ trust sys <$> ps
|
||||
trustConjunction sys ps = Trust $ product $ (getTrust . trust sys) <$> ps
|
||||
|
||||
progress ∷ ProjectSystem → ProjectExpr → Progress
|
||||
progress sys (Reference n) =
|
||||
@ -190,10 +198,10 @@ prioritizeSys sys = everywhere (mkT $ prioritizeProj sys) sys
|
||||
-- |Sort project in order that minimizes cost
|
||||
prioritizeProj ∷ ProjectSystem → ProjectExpr → ProjectExpr
|
||||
prioritizeProj sys (Sum ps) =
|
||||
let f p = cost sys p / trust sys p
|
||||
let f p = getCost (cost sys p) / getTrust (trust sys p)
|
||||
in Sum $ NE.sortWith (nanToInf . f) $ prioritizeProj sys <$> ps
|
||||
prioritizeProj sys (Product ps) =
|
||||
let f p = cost sys p / (1 - trust sys p)
|
||||
let f p = getCost (cost sys p) / (1 - getTrust (trust sys p))
|
||||
in Product $ NE.sortWith (nanToInf . f) $ prioritizeProj sys <$> ps
|
||||
prioritizeProj _ p = p
|
||||
|
||||
|
||||
@ -22,10 +22,11 @@ debugSys ∷ ProjectSystem → IO ()
|
||||
debugSys sys@(ProjectSystem bs) = void $ M.traverseWithKey printBinding bs
|
||||
where
|
||||
printBinding key b = do putStrLn "-------------------"
|
||||
putStr $ key ++ " = "
|
||||
putStr $ getProjectKey key ++ " = "
|
||||
case b of
|
||||
BindingExpr _ e -> putStr "\n" >> debugProj sys e
|
||||
BindingAtomic _ c t p -> putStrLn $ printf "(c:%.2f,t:%.2f,p:%2.f)" c t p
|
||||
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.
|
||||
@ -36,9 +37,12 @@ debugProj sys = print' 0
|
||||
ident il = replicateM_ il $ putStr " |"
|
||||
|
||||
print' ∷ Int → ProjectExpr → IO ()
|
||||
print' il p@(Reference n) = ident il >> putStr ("-" ++ n ++ " ") >> ctp p
|
||||
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)
|
||||
|
||||
ctp p = putStrLn $ printf " c=%.2f t=%.2f p=%.2f" (cost sys p) (trust sys p) (progress sys p)
|
||||
ctp p = putStrLn $ printf " c=%.2f t=%.2f p=%.2f"
|
||||
(getCost $ cost sys p)
|
||||
(getTrust $ trust sys p)
|
||||
(getProgress $ progress sys p)
|
||||
|
||||
@ -7,13 +7,13 @@ Maintainer : rodrigosetti@gmail.com
|
||||
Stability : experimental
|
||||
Portability : POSIX
|
||||
-}
|
||||
{-# LANGUAGE UnicodeSyntax #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE UnicodeSyntax #-}
|
||||
module MasterPlan.Parser (runParser) where
|
||||
|
||||
import Control.Monad.State
|
||||
import Control.Applicative (empty)
|
||||
import Control.Monad.State
|
||||
import Data.Generics hiding (empty)
|
||||
import Data.List (nub)
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
@ -50,8 +50,8 @@ rws = map show [minBound :: ProjAttribute ..]
|
||||
identifier ∷ Parser String
|
||||
identifier = (lexeme . try) $ (:) <$> letterChar <*> many alphaNumChar
|
||||
|
||||
nonKeywordIdentifier :: Parser String
|
||||
nonKeywordIdentifier = identifier >>= check
|
||||
projectKey :: Parser ProjectKey
|
||||
projectKey = ProjectKey <$> (identifier >>= check) <?> "project key"
|
||||
where
|
||||
check x
|
||||
| x `elem` rws = fail $ "keyword " ++ show x ++ " cannot be an identifier"
|
||||
@ -73,7 +73,7 @@ expression ∷ Parser ProjectExpr
|
||||
expression =
|
||||
simplifyProj <$> makeExprParser term table <?> "expression"
|
||||
where
|
||||
term = parens expression <|> (Reference <$> nonKeywordIdentifier)
|
||||
term = parens expression <|> (Reference <$> projectKey)
|
||||
table = [[binary "*" (combineWith Product)]
|
||||
,[binary "->" (combineWith Sequence)]
|
||||
,[binary "+" (combineWith Sum)]]
|
||||
@ -99,15 +99,15 @@ binding key = do (props, mc, mt, mp) <- try simpleTitle <|> try bracketAttribute
|
||||
attrKey = do n <- identifier <?> "attribute name"
|
||||
case lookup n [(show a, a) | a <- [minBound::ProjAttribute ..]] of
|
||||
Nothing -> fail $ "invalid attribute: \"" ++ n ++ "\""
|
||||
Just a -> pure a
|
||||
Just a -> pure a
|
||||
|
||||
simpleTitle, bracketAttributes, noAttributes :: Parser (ProjectProperties, Maybe Cost, Maybe Trust, Maybe Progress)
|
||||
simpleTitle = do s <- stringLiteral <?> "title"
|
||||
pure (defaultProjectProps {title=s}, Nothing, Nothing, Nothing)
|
||||
|
||||
bracketAttributes = symbol "{" *> attributes (defaultProjectProps {title=key}) Nothing Nothing Nothing
|
||||
bracketAttributes = symbol "{" *> attributes (defaultProjectProps {title=getProjectKey key}) Nothing Nothing Nothing
|
||||
|
||||
noAttributes = pure (defaultProjectProps {title=key}, Nothing, Nothing, Nothing)
|
||||
noAttributes = pure (defaultProjectProps {title=getProjectKey key}, Nothing, Nothing, Nothing)
|
||||
|
||||
attributes :: ProjectProperties -> Maybe Cost -> Maybe Trust -> Maybe Progress
|
||||
-> Parser (ProjectProperties, Maybe Cost, Maybe Trust, Maybe Progress)
|
||||
@ -127,13 +127,13 @@ binding key = do (props, mc, mt, mp) <- try simpleTitle <|> try bracketAttribute
|
||||
s <- stringLiteral <?> "owner"
|
||||
attributes (props {owner=Just s}) mc mt mp
|
||||
PCost -> do when (isJust mc) $ fail "redefinition of cost"
|
||||
c <- nonNegativeNumber <?> "cost"
|
||||
c <- Cost <$> nonNegativeNumber <?> "cost"
|
||||
attributes props (Just c) mt mp
|
||||
PTrust -> do when (isJust mt) $ fail "redefinition of cost"
|
||||
t <- percentage <?> "trust"
|
||||
t <- Trust <$> percentage <?> "trust"
|
||||
attributes props mc (Just t) mp
|
||||
PProgress -> do when (isJust mp) $ fail "redefinition of progress"
|
||||
p <- percentage <?> "progress"
|
||||
p <- Progress <$> percentage <?> "progress"
|
||||
attributes props mc mt (Just p)
|
||||
|
||||
|
||||
@ -150,13 +150,13 @@ projectSystem =
|
||||
where
|
||||
mkProjSystem = ProjectSystem . M.fromList
|
||||
|
||||
definitions ds = do key <- sc *> nonKeywordIdentifier <?> "project key"
|
||||
when (key `elem` map fst ds) $ fail $ "redefinition of \"" ++ key ++ "\""
|
||||
definitions ds = do key <- sc *> projectKey
|
||||
when (key `elem` map fst ds) $ fail $ "redefinition of \"" ++ getProjectKey key ++ "\""
|
||||
b <- binding key <* symbol ";"
|
||||
|
||||
-- check if it's recursive
|
||||
let deps = dependencies (mkProjSystem ds) b
|
||||
when (key `elem` deps) $ fail $ "definition of \"" ++ key ++ "\" is recursive"
|
||||
when (key `elem` deps) $ fail $ "definition of \"" ++ getProjectKey key ++ "\" is recursive"
|
||||
|
||||
let ds' = (key,b):ds
|
||||
(try eof *> pure ds') <|> definitions ds'
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE UnicodeSyntax #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE UnicodeSyntax #-}
|
||||
module MasterPlan.Arbitrary () where
|
||||
|
||||
import Control.Monad (replicateM)
|
||||
@ -20,7 +21,7 @@ instance Arbitrary ProjectProperties where
|
||||
(if isNothing (url p) then [] else [p { url = Nothing }]) ++
|
||||
(if isNothing (owner p) then [] else [p { owner = Nothing }])
|
||||
|
||||
testingKeys ∷ [String]
|
||||
testingKeys ∷ [ProjectKey]
|
||||
testingKeys = ["a", "b", "c", "d"]
|
||||
|
||||
instance Arbitrary ProjectSystem where
|
||||
@ -32,7 +33,7 @@ instance Arbitrary ProjectSystem where
|
||||
shrink (ProjectSystem bs) =
|
||||
map ProjectSystem $ concatMap shrinkOne testingKeys
|
||||
where
|
||||
shrinkOne ∷ String → [M.Map String Binding]
|
||||
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
|
||||
@ -44,12 +45,12 @@ instance Arbitrary Binding where
|
||||
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
|
||||
<*> elements [0, 1 .. 100]
|
||||
<*> unitGen
|
||||
<*> unitGen
|
||||
<*> (Cost <$> elements [0, 1 .. 100])
|
||||
<*> (Trust <$> unitGen)
|
||||
<*> (Progress <$> unitGen)
|
||||
|
||||
shrink (BindingExpr pr e) = map (BindingExpr pr) $ shrink e
|
||||
shrink _ = []
|
||||
shrink _ = []
|
||||
|
||||
instance Arbitrary ProjectExpr where
|
||||
|
||||
@ -63,4 +64,4 @@ instance Arbitrary ProjectExpr where
|
||||
shrink (Sum ps) = NE.toList ps
|
||||
shrink (Product ps) = NE.toList ps
|
||||
shrink (Sequence ps) = NE.toList ps
|
||||
shrink (Reference _) = []
|
||||
shrink (Reference _) = []
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE UnicodeSyntax #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE UnicodeSyntax #-}
|
||||
module MasterPlan.DataSpec (spec) where
|
||||
|
||||
import Control.Monad.State
|
||||
@ -11,8 +12,8 @@ import MasterPlan.Data
|
||||
import System.Random
|
||||
import System.Random.Shuffle (shuffle')
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck hiding (sample)
|
||||
import Test.Hspec.QuickCheck (prop)
|
||||
import Test.QuickCheck hiding (sample)
|
||||
|
||||
-- |Sample the simulation model of the execution of a project.
|
||||
-- It's a stateful computation with the random generator, which computes
|
||||
@ -21,12 +22,12 @@ import Test.Hspec.QuickCheck (prop)
|
||||
simulate ∷ RandomGen g ⇒ ProjectSystem → ProjectExpr → State g (Bool, Cost)
|
||||
simulate sys (Reference n) =
|
||||
case M.lookup n (bindings sys) of
|
||||
Just (BindingAtomic _ c t p) ->
|
||||
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, effectiveCost)
|
||||
pure (effectiveTrust > r, Cost effectiveCost)
|
||||
Just (BindingExpr _ p) -> simulate sys p -- TODO:30 avoid cyclic
|
||||
Nothing -> pure (True, defaultCost)
|
||||
|
||||
@ -65,7 +66,7 @@ monteCarloTrustAndCost n sys p = do results <- replicateM n $ simulate sys p
|
||||
pure (sum trusts / fromIntegral n,
|
||||
sum costs / fromIntegral n)
|
||||
|
||||
aproximatelyEqual ∷ Float -> Float -> Float → Float -> Property
|
||||
aproximatelyEqual ∷ (Show a, Real a, Fractional a) => a -> a -> a → a -> Property
|
||||
aproximatelyEqual alpha beta x y =
|
||||
counterexample (show x ++ " /= " ++ show y) $ diff <= max relError beta
|
||||
where
|
||||
@ -78,7 +79,8 @@ spec = do
|
||||
|
||||
let g = mkStdGen 837183
|
||||
|
||||
let eq = aproximatelyEqual 0.05 0.05
|
||||
let eq :: (Show a, Real a, Fractional a) => a -> a -> Property
|
||||
eq = aproximatelyEqual 0.05 0.05
|
||||
|
||||
prop "monte-carlo and analytical implementations should agree" $ do
|
||||
let p = Reference "root"
|
||||
@ -92,7 +94,8 @@ spec = do
|
||||
|
||||
describe "simplification" $ do
|
||||
|
||||
let eq = aproximatelyEqual 0.005 0.005
|
||||
let eq :: (Show a, Real a, Fractional a) => a -> a -> Property
|
||||
eq = aproximatelyEqual 0.005 0.005
|
||||
|
||||
prop "is irreductible" $ do
|
||||
let simplificationIsIrreductible :: ProjectExpr -> Property
|
||||
@ -119,9 +122,9 @@ spec = do
|
||||
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 (Sum ps) = Sum <$> shuffleProjs ps
|
||||
shuffleProj (Product ps) = Product <$> shuffleProjs ps
|
||||
shuffleProj p = pure p
|
||||
|
||||
prop "minimize cost and keep trust stable" $ do
|
||||
-- This test verifies that for any arbitrary project tree, the
|
||||
|
||||
Loading…
Reference in New Issue
Block a user