diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 0000000..1a1eaf0 --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,204 @@ +# stylish-haskell configuration file +# ================================== + +# The stylish-haskell tool is mainly configured by specifying steps. These steps +# are a list, so they have an order, and one specific step may appear more than +# once (if needed). Each file is processed by these steps in the given order. +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 + + # Align the right hand side of some elements. This is quite conservative + # and only applies to statements where each element occupies a single + # line. + - simple_align: + cases: true + top_level_patterns: true + records: true + + # Import cleanup + - imports: + # There are different ways we can align names and lists. + # + # - global: Align the import names and import list throughout the entire + # file. + # + # - file: Like global, but don't add padding when there are no qualified + # imports in the file. + # + # - group: Only align the imports per group (a group is formed by adjacent + # import lines). + # + # - none: Do not perform any alignment. + # + # Default: global. + align: global + + # The following options affect only import list alignment. + # + # List align has following options: + # + # - after_alias: Import list is aligned with end of import including + # 'as' and 'hiding' keywords. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_alias: Import list is aligned with start of alias or hiding. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - new_line: Import list starts always on new line. + # + # > import qualified Data.List as List + # > (concat, foldl, foldr, head, init, last, length) + # + # Default: after_alias + list_align: after_alias + + # Right-pad the module names to align imports in a group: + # + # - true: a little more readable + # + # > import qualified Data.List as List (concat, foldl, foldr, + # > init, last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # - false: diff-safe + # + # > import qualified Data.List as List (concat, foldl, foldr, init, + # > last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # Default: true + pad_module_names: true + + # Long list align style takes effect when import is too long. This is + # determined by 'columns' setting. + # + # - inline: This option will put as much specs on same line as possible. + # + # - new_line: Import list will start on new line. + # + # - new_line_multiline: Import list will start on new line when it's + # short enough to fit to single line. Otherwise it'll be multiline. + # + # - multiline: One line per import list entry. + # Type with constructor list acts like single import. + # + # > import qualified Data.Map as M + # > ( empty + # > , singleton + # > , ... + # > , delete + # > ) + # + # Default: inline + long_list_align: inline + + # Align empty list (importing instances) + # + # Empty list align has following options + # + # - inherit: inherit list_align setting + # + # - right_after: () is right after the module name: + # + # > import Vector.Instances () + # + # Default: inherit + empty_list_align: inherit + + # List padding determines indentation of import list on lines after import. + # This option affects 'long_list_align'. + # + # - : constant value + # + # - module_name: align under start of module name. + # Useful for 'file' and 'group' align settings. + list_padding: 4 + + # Separate lists option affects formatting of import list for type + # or class. The only difference is single space between type and list + # of constructors, selectors and class functions. + # + # - true: There is single space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable (fold, foldl, foldMap)) + # + # - false: There is no space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable(fold, foldl, foldMap)) + # + # Default: true + separate_lists: true + + # Space surround option affects formatting of import lists on a single + # line. The only difference is single space after the initial + # parenthesis and a single space before the terminal parenthesis. + # + # - true: There is single space associated with the enclosing + # parenthesis. + # + # > import Data.Foo ( foo ) + # + # - false: There is no space associated with the enclosing parenthesis + # + # > import Data.Foo (foo) + # + # Default: false + space_surround: false + + # Language pragmas + - language_pragmas: + # We can generate different styles of language pragma lists. + # + # - vertical: Vertical-spaced language pragmas, one per line. + # + # - compact: A more compact style. + # + # - compact_line: Similar to compact, but wrap each line with + # `{-#LANGUAGE #-}'. + # + # Default: vertical. + style: vertical + + # Align affects alignment of closing pragma brackets. + # + # - true: Brackets are aligned in same column. + # + # - false: Brackets are not aligned together. There is only one space + # between actual import and closing bracket. + # + # Default: true + align: true + + # stylish-haskell can detect redundancy of some language pragmas. If this + # is set to true, it will remove those redundant pragmas. Default: true. + remove_redundant: true + + # Replace tabs by spaces. + - tabs: + spaces: 8 + + # Remove trailing whitespace + - trailing_whitespace: {} + +columns: 80 +newline: lf + +language_extensions: + - UnicodeSyntax + - OverloadedStrings diff --git a/master-plan.cabal b/master-plan.cabal index 338dcb1..fe0f599 100644 --- a/master-plan.cabal +++ b/master-plan.cabal @@ -2,9 +2,13 @@ name: master-plan version: 0.1.0.0 synopsis: Text based project management tool -- description: -homepage: https://github.com/rsetti/master-plan#readme +homepage: https://github.com/rodrigosetti/master-plan +bug-reports: https://github.com/rodrigosetti/master-plan/issues author: Rodrigo Setti maintainer: rodrigosetti@gmail.com +stability: alpha +license: MIT +license-file: LICENSE copyright: 2017 Rodrigo Setti. All rights reserved category: Tools build-type: Simple @@ -27,6 +31,7 @@ library default-language: Haskell2010 ghc-options: -Wall default-extensions: OverloadedStrings + , UnicodeSyntax build-depends: base , megaparsec , containers diff --git a/src/MasterPlan/Data.hs b/src/MasterPlan/Data.hs index cff68fc..79f9021 100644 --- a/src/MasterPlan/Data.hs +++ b/src/MasterPlan/Data.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UnicodeSyntax #-} module MasterPlan.Data where import Data.Foldable (asum) @@ -14,18 +15,10 @@ data Status = Ready | Blocked | InProgress | Done | Cancelled deriving (Eq, Show) -- |Structure of a project expression -data Project = SumProj { - subprojects :: NE.NonEmpty Project - } | - ProductProj { - subprojects :: NE.NonEmpty Project - } | - SequenceProj { - subprojects :: NE.NonEmpty Project - } | - RefProj { - name :: String - } +data Project = SumProj { subprojects :: NE.NonEmpty Project } | + ProductProj { subprojects :: NE.NonEmpty Project } | + SequenceProj { subprojects :: NE.NonEmpty Project } | + RefProj { name :: String } deriving (Eq, Show) -- |A binding of a name can refer to an expression. If there are no @@ -54,35 +47,35 @@ data ProjectProperties = ProjectProperties { title :: String newtype ProjectSystem = ProjectSystem { bindings :: M.Map String ProjectBinding } deriving (Eq, Show) -defaultProjectProps :: ProjectProperties +defaultProjectProps ∷ ProjectProperties defaultProjectProps = ProjectProperties { title = "root" , description = Nothing , url = Nothing , owner = Nothing } -isOpen :: ProjectSystem -> Project -> Bool +isOpen ∷ ProjectSystem → Project → Bool isOpen sys p = status sys p `elem` [InProgress, Ready, Blocked] -isClosed :: ProjectSystem -> Project -> Bool +isClosed ∷ ProjectSystem → Project → Bool isClosed sys p = not $ isOpen sys p -- | Expected cost -cost :: ProjectSystem -> Project -> Cost +cost ∷ ProjectSystem → Project → Cost cost sys (RefProj n) = case M.lookup n (bindings sys) of Just TaskProj { reportedCost=c } -> c Just ExpressionProj { expression=p} -> cost sys p -- TODO: avoid cyclic Nothing -> 0 -- should not happen -cost sys SequenceProj { subprojects=ps } = costConjunction sys $ NE.dropWhile (isClosed sys) ps -cost sys ProductProj { subprojects=ps } = costConjunction sys $ NE.filter (isOpen sys) ps -cost sys SumProj { subprojects=s } = +cost sys (SequenceProj ps) = costConjunction sys $ NE.dropWhile (isClosed sys) ps +cost sys (ProductProj ps) = costConjunction sys $ NE.filter (isOpen sys) ps +cost sys (SumProj ps) = sum $ map (\x -> (1 - snd x) * fst x) $ zip costs accTrusts where accTrusts = scanl (\a b -> a + b*(1-a)) 0 $ map (trust sys) opens costs = map (cost sys) opens - opens = NE.filter (isOpen sys) s + opens = NE.filter (isOpen sys) ps -costConjunction :: ProjectSystem -> [Project] -> Cost +costConjunction ∷ ProjectSystem → [Project] → Cost costConjunction sys ps = sum $ zipWith (*) costs accTrusts where @@ -90,57 +83,57 @@ costConjunction sys ps = accTrusts = map product $ inits $ map (trust sys) ps -- | Expected trust probability -trust :: ProjectSystem -> Project -> Trust +trust ∷ ProjectSystem → Project → Trust trust sys (RefProj n) = case M.lookup n (bindings sys) of Just TaskProj { reportedTrust=t } -> t Just ExpressionProj { expression=p} -> trust sys p -- TODO: avoid cyclic Nothing -> 0 -- should not happen -trust sys SequenceProj { subprojects=ps } = trustConjunction sys $ NE.dropWhile (isClosed sys) ps -trust sys ProductProj { subprojects=ps } = trustConjunction sys $ NE.filter (isOpen sys) ps -trust sys SumProj { subprojects=s } = +trust sys (SequenceProj ps) = trustConjunction sys $ NE.dropWhile (isClosed sys) ps +trust sys (ProductProj ps) = trustConjunction sys $ NE.filter (isOpen sys) ps +trust sys (SumProj ps) = if null opens then 1 else accTrusts where accTrusts = foldl (\a b -> a + b*(1-a)) 0 $ map (trust sys) opens - opens = NE.filter (isOpen sys) s + opens = NE.filter (isOpen sys) ps -trustConjunction :: ProjectSystem -> [Project] -> Trust +trustConjunction ∷ ProjectSystem → [Project] → Trust trustConjunction sys ps = product $ map (trust sys) ps -progress ::ProjectSystem -> Project -> Progress +progress ∷ProjectSystem → Project → Progress progress sys (RefProj n) = case M.lookup n (bindings sys) of Just TaskProj { reportedStatus=Done } -> 1 Just TaskProj { reportedProgress=p } -> p Just ExpressionProj { expression=p} -> progress sys p -- TODO: avoid cyclic Nothing -> 0 -- should not happen -progress sys SequenceProj { subprojects=s } = progressConjunction sys s -progress sys ProductProj { subprojects=s } = progressConjunction sys s -progress sys SumProj { subprojects=s } = maximum $ NE.map (progress sys) s +progress sys (SequenceProj ps) = progressConjunction sys ps +progress sys (ProductProj ps) = progressConjunction sys ps +progress sys (SumProj ps) = maximum $ NE.map (progress sys) ps -progressConjunction :: ProjectSystem -> NE.NonEmpty Project -> Progress +progressConjunction ∷ ProjectSystem → NE.NonEmpty Project → Progress progressConjunction sys ps = let opens = NE.filter (isOpen sys) ps in if null opens then 1 else sum (map (progress sys) opens) / fromIntegral (length opens) -status :: ProjectSystem -> Project -> Status +status ∷ ProjectSystem → Project → Status status sys (RefProj n) = case M.lookup n (bindings sys) of Just TaskProj { reportedProgress=p, reportedStatus=s } -> if p>=1 then Done else s Just ExpressionProj { expression=p} -> status sys p -- TODO: avoid cyclic Nothing -> Cancelled -- should not happen -status sys SequenceProj { subprojects=s } = - let rest = NE.dropWhile (isClosed sys) s +status sys (SequenceProj ps) = + let rest = NE.dropWhile (isClosed sys) ps in case rest of (p : _) -> status sys p [] -> Done -status sys ProductProj { subprojects=ps } = +status sys (ProductProj ps) = statusPriority [InProgress, Ready, Blocked, Cancelled, Done] sys ps -status sys SumProj { subprojects=ps } = +status sys (SumProj ps) = statusPriority [Done, InProgress, Ready, Blocked, Cancelled] sys ps -statusPriority :: [Status] -> ProjectSystem -> NE.NonEmpty Project -> Status +statusPriority ∷ [Status] → ProjectSystem → NE.NonEmpty Project → Status statusPriority priority sys ps = let ss = NE.map (status sys) ps in fromMaybe Done $ asum $ map (\x -> find (x ==) ss) priority diff --git a/test/MasterPlan/DataSpec.hs b/test/MasterPlan/DataSpec.hs index e3e68b4..057e34d 100644 --- a/test/MasterPlan/DataSpec.hs +++ b/test/MasterPlan/DataSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UnicodeSyntax #-} module MasterPlan.DataSpec where import Data.Bool (bool) @@ -8,6 +9,7 @@ import Test.QuickCheck hiding (sample) import Control.Applicative ((<$>), (<*>)) import Control.Monad.State +import Data.List (nub) import qualified Data.List.NonEmpty as NE import System.Random @@ -28,12 +30,15 @@ instance Arbitrary ProjectProperties where instance Arbitrary Status where - arbitrary = oneof [ pure Ready, pure Blocked, pure InProgress, pure Done, pure Cancelled ] + arbitrary = elements [ Ready, Blocked, InProgress, Done, Cancelled ] -testingKeys :: [String] + shrink Done = [] + shrink _ = [Done] + +testingKeys ∷ [String] testingKeys = ["a","b","c","d"] -rootKey :: String +rootKey ∷ String rootKey = "root" instance Arbitrary ProjectSystem where @@ -41,13 +46,12 @@ instance Arbitrary ProjectSystem where arbitrary = do bs <- replicateM (length testingKeys) arbitrary let arbitraryExpr = ExpressionProj <$> arbitrary <*> arbitrary rootB <- frequency [ (1, arbitrary), (10, arbitraryExpr) ] - let bindings = M.insert rootKey rootB $ M.fromList $ zip testingKeys bs - pure $ ProjectSystem bindings + pure $ ProjectSystem $ M.insert rootKey rootB $ M.fromList $ zip testingKeys bs shrink (ProjectSystem bs) = map ProjectSystem $ concatMap shrinkOne testingKeys where - shrinkOne :: String -> [M.Map String ProjectBinding] + shrinkOne ∷ String → [M.Map String ProjectBinding] shrinkOne k = case M.lookup k bs of Nothing -> [] Just b -> map (\s -> M.adjust (const s) k bs) $ shrink b @@ -64,6 +68,12 @@ instance Arbitrary ProjectBinding where <*> arbitrary <*> unitGen + shrink b = nub [ b { reportedCost=0 } + , b { reportedCost=1 } + , b { reportedTrust=0 } + , b { reportedTrust=1 } + , b { reportedStatus=Done } ] + instance Arbitrary Project where arbitrary = @@ -78,11 +88,11 @@ instance Arbitrary Project where shrink (SequenceProj ps) = map SequenceProj (shrink ps) ++ NE.toList ps shrink (RefProj _) = [] -average :: RandomGen g => State g Float -> Int -> State g Float +average ∷ RandomGen g ⇒ State g Float → Int → State g Float average sample n = do total <- replicateM n sample pure $ sum total / fromIntegral n -simulate :: RandomGen g => ProjectSystem -> Project -> State g (Bool, Cost) +simulate ∷ RandomGen g ⇒ ProjectSystem → Project → State g (Bool, Cost) simulate sys (RefProj n) = case M.lookup n (bindings sys) of Just TaskProj { reportedTrust=t, reportedCost=c } -> @@ -97,7 +107,7 @@ simulate sys SumProj { subprojects=ps } = if null opens then pure (True, 0) else simulate' opens where opens = NE.filter (isOpen sys) ps - simulate' :: RandomGen g => [Project] -> State g (Bool, Cost) + simulate' ∷ RandomGen g ⇒ [Project] → State g (Bool, Cost) simulate' [] = pure (False, 0) simulate' (p:rest) = do (success, c) <- simulate sys p if success then @@ -106,7 +116,7 @@ simulate sys SumProj { subprojects=ps } = do (success', c') <- simulate' rest pure (success', c + c') -simulateConjunction :: RandomGen g => ProjectSystem -> [Project] -> State g (Bool, Cost) +simulateConjunction ∷ RandomGen g ⇒ ProjectSystem → [Project] → State g (Bool, Cost) simulateConjunction _ [] = pure (True, 0) simulateConjunction sys (p:rest) = do (success, c) <- simulate sys p if success then do @@ -115,27 +125,27 @@ simulateConjunction sys (p:rest) = do (success, c) <- simulate sys p else pure (False, c) -monteCarloTrusteAndCost :: RandomGen g => Int -> ProjectSystem -> Project -> State g (Trust, Cost) +monteCarloTrusteAndCost ∷ RandomGen g ⇒ Int → ProjectSystem → Project → State g (Trust, Cost) monteCarloTrusteAndCost n sys p = do results <- replicateM n $ simulate sys p let trusts = map (bool 0 1 . fst) results let costs = map snd results pure (sum trusts / fromIntegral n, sum costs / fromIntegral n) -aproximatelyEqual :: Float -> Float -> Property +aproximatelyEqual ∷ Float → Float → Property aproximatelyEqual x y = counterexample (show x ++ " /= " ++ show y) (abs (x - y) <= epislon) where epislon = 0.05 -spec :: Spec +spec ∷ Spec spec = do describe "estimations" $ do let g = mkStdGen 837183 it "monte-carlo and analytical implementations should agree on cost" $ do - let propertyMCAndAnalyticalEq :: ProjectSystem -> Property + let propertyMCAndAnalyticalEq ∷ ProjectSystem → Property propertyMCAndAnalyticalEq sys = cost' `aproximatelyEqual` cost sys p where @@ -145,7 +155,7 @@ spec = do property propertyMCAndAnalyticalEq it "monte-carlo and analytical implementations should agree on trust" $ do - let propertyMCAndAnalyticalEq :: ProjectSystem -> Property + let propertyMCAndAnalyticalEq ∷ ProjectSystem → Property propertyMCAndAnalyticalEq sys = trust' `aproximatelyEqual` trust sys p where