Refactor: using newtypes

.stylish-haskell.yaml

@@ -7,13 +7,13 @@
 steps:
   # Convert some ASCII sequences to their Unicode equivalents. This is disabled
   # by default.
-  - unicode_syntax:
+  #- unicode_syntax:
-     # In order to make this work, we also need to insert the UnicodeSyntax
+  #   # 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
+  #   # 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
+  #   # not already present. You may want to disable it if you configure
-     # language extensions using some other method than pragmas. Default:
+  #   # language extensions using some other method than pragmas. Default:
-     # true.
+  #   # true.
-     add_language_pragma: 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

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"
+                                        <*> (ProjectKey <$> strOption ( long "root"
                                                                      <> short 'r'
                                                                      <> help "name of the root project definition"
                                                                      <> value "root"
                                                                      <> showDefault
-                                                       <> metavar "NAME")
+                                                                     <> metavar "NAME"))
                                         <*> (invertProps <$> many (option property ( long "hide"
                                                                                    <> help "hide a particular property"
                                                                                    <> metavar (intercalate "|" $ map fst propertyNames))))
@@ -80,7 +80,7 @@ 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"
+    filterParser = (ProjFilter . mkProgressFilter . Progress) <$> option auto ( long "progress-below"
                                                                               <> help "only display projects which progress is < N%"
                                                                               <> metavar "N" )
       where

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.Monad.State
-import qualified Data.Map  as M
+import           Data.List                   (intersperse)
-import           Data.Tree
-import           Data.Maybe (fromMaybe, catMaybes)
 import qualified Data.List.NonEmpty          as NE
-import           Text.Printf (printf)
+import qualified Data.Map                    as M
+import           Data.Maybe                  (catMaybes, fromMaybe)
+import           Data.Tree
+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
@@ -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
@@ -105,7 +106,7 @@ data RenderOptions = RenderOptions { colorByProgress :: Bool -- ^Whether to colo
 -- | 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
 
@@ -136,7 +137,7 @@ renderTree colorByP props x@(Node (ty, n) ts@(t:_)) =
       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"

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 (c /= defaultCost) $ tell $ "cost " <> T.pack (show $ getCost c) <> "\n"
-        when (t /= defaultTrust) $ tell $ "trust " <> percentage t <> "\n"
+        when (t /= defaultTrust) $ tell $ "trust " <> percentage (getTrust t) <> "\n"
-        when (p /= defaultProgress) $ tell $ "progress " <> percentage p <> "\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,7 +80,7 @@ renderName projName =
                                   in if parens && length ps > 1 then "(" <> s <> ")" else s
 
    expressionToStr :: Bool -> ProjectExpr -> T.Text
-   expressionToStr _      (Reference n) = T.pack n
+   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

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
+                       , Trust(..)
-                       , Cost
+                       , Cost(..)
-                       , Progress
+                       , 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
+newtype Trust = Trust { getTrust :: Float }
-type Cost = Float
+  deriving (Show, Eq, Data, Ord, Num, Real, RealFrac, Fractional)
-type Progress = Float
+newtype Cost = Cost { getCost :: Float }
-type ProjectKey = String
+  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 $ (getCost . cost sys) <$> ps
-   costs = NE.toList $ 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
+    costs = NE.toList $ (getCost . cost sys) <$> ps
-    accTrusts = NE.toList $ product <$> NE.inits (trust 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
 

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)

src/MasterPlan/Parser.hs

@@ -7,13 +7,13 @@ Maintainer  : rodrigosetti@gmail.com
 Stability   : experimental
 Portability : POSIX
 -}
-{-# LANGUAGE UnicodeSyntax #-}
 {-# 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
+projectKey :: Parser ProjectKey
-nonKeywordIdentifier = identifier >>= check
+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)]]
@@ -105,9 +105,9 @@ binding key = do (props, mc, mt, mp) <- try simpleTitle <|> try bracketAttribute
    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"
+   definitions ds = do key <- sc *> projectKey
-                       when (key `elem` map fst ds) $ fail $ "redefinition of \"" ++ key ++ "\""
+                       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'

test/MasterPlan/Arbitrary.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE UnicodeSyntax     #-}
 module MasterPlan.Arbitrary () where
 
@@ -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,9 +45,9 @@ 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]
+                      <*> (Cost <$> elements [0, 1 .. 100])
-                      <*> unitGen
+                      <*> (Trust <$> unitGen)
-                      <*> unitGen
+                      <*> (Progress <$> unitGen)
 
   shrink (BindingExpr pr e) = map (BindingExpr pr) $ shrink e
   shrink _                  = []

test/MasterPlan/DataSpec.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE UnicodeSyntax     #-}
 module MasterPlan.DataSpec (spec) where
 
@@ -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