From 73baeba40b528825f538145c78916ebd7c576d3a Mon Sep 17 00:00:00 2001 From: Rodrigo Setti Date: Tue, 15 Aug 2017 22:26:01 -0700 Subject: [PATCH] Refactor: using newtypes --- .stylish-haskell.yaml | 14 ++++---- app/Main.hs | 20 +++++------ src/MasterPlan/Backend/Graph.hs | 53 +++++++++++++++--------------- src/MasterPlan/Backend/Identity.hs | 31 ++++++++--------- src/MasterPlan/Data.hs | 48 ++++++++++++++++----------- src/MasterPlan/Internal/Debug.hs | 12 ++++--- src/MasterPlan/Parser.hs | 30 ++++++++--------- test/MasterPlan/Arbitrary.hs | 17 +++++----- test/MasterPlan/DataSpec.hs | 23 +++++++------ 9 files changed, 133 insertions(+), 115 deletions(-) diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml index 79ee419..ef809f0 100644 --- a/.stylish-haskell.yaml +++ b/.stylish-haskell.yaml @@ -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 diff --git a/app/Main.hs b/app/Main.hs index 0ea1aad..459a39b 100644 --- a/app/Main.hs +++ b/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) diff --git a/src/MasterPlan/Backend/Graph.hs b/src/MasterPlan/Backend/Graph.hs index 1ade2b9..8a22e87 100644 --- a/src/MasterPlan/Backend/Graph.hs +++ b/src/MasterPlan/Backend/Graph.hs @@ -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" diff --git a/src/MasterPlan/Backend/Identity.hs b/src/MasterPlan/Backend/Identity.hs index 2eced70..4aa8ed0 100644 --- a/src/MasterPlan/Backend/Identity.hs +++ b/src/MasterPlan/Backend/Identity.hs @@ -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 _ = [] diff --git a/src/MasterPlan/Data.hs b/src/MasterPlan/Data.hs index 0fda5c5..2100605 100644 --- a/src/MasterPlan/Data.hs +++ b/src/MasterPlan/Data.hs @@ -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 diff --git a/src/MasterPlan/Internal/Debug.hs b/src/MasterPlan/Internal/Debug.hs index c168bc1..4fa61d1 100644 --- a/src/MasterPlan/Internal/Debug.hs +++ b/src/MasterPlan/Internal/Debug.hs @@ -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) diff --git a/src/MasterPlan/Parser.hs b/src/MasterPlan/Parser.hs index f6a7220..679dd46 100644 --- a/src/MasterPlan/Parser.hs +++ b/src/MasterPlan/Parser.hs @@ -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' diff --git a/test/MasterPlan/Arbitrary.hs b/test/MasterPlan/Arbitrary.hs index f4c242c..affaddf 100644 --- a/test/MasterPlan/Arbitrary.hs +++ b/test/MasterPlan/Arbitrary.hs @@ -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 _) = [] diff --git a/test/MasterPlan/DataSpec.hs b/test/MasterPlan/DataSpec.hs index 38ac35d..f20c729 100644 --- a/test/MasterPlan/DataSpec.hs +++ b/test/MasterPlan/DataSpec.hs @@ -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