stabilized code that simplifies

.ghci

@@ -1,2 +1 @@
 :set -XUnicodeSyntax
-:set prompt "\ESC[1;34m%s\n\ESC[0;34mλ> \ESC[m"

master.plan

@@ -1,10 +1,15 @@
+description(root) = "JiE38";
+name(root) = "\133460\177268<(S#";
+//url(root) = "\149403\&0vD\10255";
+url(root) = "\0";
+owner(root) = "}|}\53331<:e";
+root = a -> a -> a * a * a * a * a + a + a;
 
-owner(root) = "rsetti";
-
-root = a + b;
-
-name(a) = "howdy";
-
-description(a) = "hello world!";
-
-status(b) = done;
+name(a) = "";
+description(a) = ",<#e?V6";
+url(a) = "ZA";
+owner(a) = "v;'cjfh";
+cost(a) = 4.0;
+status(a) = blocked;
+trust(a) = 40.0%;
+progress(a) = 70.0%;

src/MasterPlan/Data.hs

@@ -15,6 +15,7 @@ module MasterPlan.Data ( Status(..)
                        , ProjectSystem(..)
                        , ProjectBinding(..)
                        , ProjectKey
+                       , rootKey
                        , Trust
                        , Cost
                        , Progress
@@ -27,14 +28,16 @@ module MasterPlan.Data ( Status(..)
                        , isClosed
                        , isOpen
                        , simplify
-                       , simplifyProj) where
+                       , simplifyProj
+                       , printStructure) where
 
-import           Data.Foldable      (asum)
-import           Data.List          (find)
-import qualified Data.List.NonEmpty as NE
-import qualified Data.Map           as M
-import           Data.Maybe         (fromMaybe)
-import           Data.Semigroup     (sconcat)
+import           Control.Monad.Writer
+import           Data.Foldable        (asum)
+import           Data.List            (find)
+import qualified Data.List.NonEmpty   as NE
+import qualified Data.Map             as M
+import           Data.Maybe           (fromMaybe)
+import           Data.Semigroup       (sconcat)
 
 type Trust = Float
 type Cost = Float
@@ -78,8 +81,11 @@ data ProjectProperties = ProjectProperties { title       :: String
 newtype ProjectSystem = ProjectSystem { bindings :: M.Map ProjectKey ProjectBinding }
                           deriving (Eq, Show)
 
+rootKey ∷ ProjectKey
+rootKey = "root"
+
 defaultProjectProps ∷ ProjectProperties
-defaultProjectProps = ProjectProperties { title = "root"
+defaultProjectProps = ProjectProperties { title = rootKey
                                         , description = Nothing
                                         , url = Nothing
                                         , owner = Nothing }
@@ -111,9 +117,8 @@ cost sys (ProductProj ps) = costConjunction 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) ps
+   accTrusts = NE.toList $ NE.scanl (\a b -> a + b*(1-a)) 0 $ NE.map (trust sys) ps
+   costs = NE.toList $ NE.map (cost sys) ps
 
 costConjunction ∷ ProjectSystem → NE.NonEmpty Project → Cost
 costConjunction sys ps =
@@ -134,10 +139,7 @@ trust sys (RefProj n) =
 trust sys (SequenceProj ps) = trustConjunction sys ps
 trust sys (ProductProj ps) = trustConjunction 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) ps
+  foldl (\a b -> a + b*(1-a)) 0 $ NE.map (trust sys) ps
 
 trustConjunction ∷ ProjectSystem → NE.NonEmpty Project → Trust
 trustConjunction sys ps = product $ NE.map (trust sys) ps
@@ -155,11 +157,7 @@ progress sys (ProductProj ps)    = progressConjunction sys ps
 progress sys (SumProj ps)        = maximum $ NE.map (progress sys) ps
 
 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)
+progressConjunction sys ps = sum (NE.map (progress sys) ps) / fromIntegral (length ps)
 
 status ∷ ProjectSystem → Project → Status
 status sys (RefProj n) =
@@ -175,7 +173,7 @@ status sys (SequenceProj ps) =
 status sys (ProductProj ps) =
   statusPriority [Progress, Ready, Blocked, Cancelled, Done] sys ps
 status sys (SumProj ps) =
-  statusPriority [Done, Progress, Ready, Blocked, Cancelled] sys ps
+  statusPriority [Done, Cancelled, Progress, Ready, Blocked] sys ps
 
 statusPriority ∷ [Status] → ProjectSystem → NE.NonEmpty Project → Status
 statusPriority priority sys ps =
@@ -214,3 +212,16 @@ simplifyProj (SequenceProj ps) =
     reduce (SequenceProj ps') = neConcatMap reduce ps'
     reduce p                  = [simplifyProj p]
 simplifyProj p@RefProj {}     = p
+
+-- |Debugging
+printStructure ∷ Project → String
+printStructure = execWriter . print' 0
+   where
+     ident ∷ Int → Writer String ()
+     ident il = replicateM_ il $ tell " |"
+
+     print' ∷ Int → Project → Writer String ()
+     print' il (RefProj n)  = ident il >> tell ("-" ++ n ++ "\n")
+     print' il (SumProj ps) = ident il >> tell "-+\n" >> forM_ ps (print' $ il+1)
+     print' il (SequenceProj ps) = ident il >> tell "->\n" >> forM_ ps (print' $ il+1)
+     print' il (ProductProj ps) = ident il >> tell "-*\n" >> forM_ ps (print' $ il+1)

src/MasterPlan/Parser.hs

@@ -14,7 +14,6 @@ module MasterPlan.Parser (runParser) where
 import           Control.Monad.State
 import qualified Data.List.NonEmpty         as NE
 import qualified Data.Map                   as M
-import           Data.Semigroup             ((<>))
 import           Data.Void
 import           MasterPlan.Data
 import           Text.Megaparsec            hiding (State, runParser)
@@ -146,31 +145,19 @@ expressionParser =
 
     combineProduct ∷ Project → Project → Project
     combineProduct p1 p2 = ProductProj $ p1 NE.<| [p2]
-    --combineProduct (ProductProj ps1) (ProductProj ps2) = ProductProj $ ps1 <> ps2
-    --combineProduct (ProductProj ps) p = ProductProj $ ps <> [p]
-    --combineProduct p (ProductProj ps) = ProductProj $ p NE.<| ps
-    --combineProduct p1 p2 = ProductProj [p1, p2]
 
     combineSequence ∷ Project → Project → Project
     combineSequence p1 p2 = SequenceProj $ p1 NE.<| [p2]
-    --combineSequence (SequenceProj ps1) (SequenceProj ps2) = SequenceProj $ ps1 <> ps2
-    --combineSequence (SequenceProj ps) p = SequenceProj $ ps <> [p]
-    --combineSequence p (SequenceProj ps) = SequenceProj $ p NE.<| ps
-    --combineSequence p1 p2 = SequenceProj [p1, p2]
 
     combineSum ∷ Project → Project → Project
     combineSum p1 p2 = SumProj $ p1 NE.<| [p2]
-    --combineSum (SumProj ps1) (SumProj ps2) = SumProj $ ps1 <> ps2
-    --combineSum (SumProj ps) p              = SumProj $ ps <> [p]
-    --combineSum p (SumProj ps)              = SumProj $ p NE.<| ps
-    --combineSum p1 p2                       = SumProj [p1, p2]
 
 
 projectSystem :: Parser ProjectSystem
 projectSystem =
     do between sc eof definitionSeq
        ps <- lift get
-       unless (M.member "root" $ bindings ps) $ fail "expected project \"root\" to be defined."
+       unless (M.member rootKey $ bindings ps) $ fail $ "expected project \"" ++ rootKey ++ "\" to be defined."
        pure ps
  where
    definitionSeq = void $ endBy1 definition (symbol ";")

test/MasterPlan/Arbitrary.hs

@@ -4,24 +4,21 @@ module MasterPlan.Arbitrary where
 import           Control.Monad             (replicateM)
 import qualified Data.List.NonEmpty        as NE
 import qualified Data.Map                  as M
+import           Data.Maybe                (isNothing)
 import           MasterPlan.Data
 import           Test.QuickCheck
 import           Test.QuickCheck.Instances ()
 
 instance Arbitrary ProjectProperties where
 
-  --arbitrary = pure defaultProjectProps
-  --{-
   arbitrary =
-      let s = getPrintableString <$> arbitrary
+      let s = getUnicodeString <$> arbitrary
           os = oneof [pure Nothing, Just <$> s]
       in ProjectProperties <$> s <*> os <*> os <*> os
-{-
-  shrink p = [ p { title = t } | t <- shrink $ title p ] ++
-             [ p { description = t } | t <- shrink $ description p ] ++
-             [ p { url = t } | t <- shrink $ url p ] ++
-             [ p { owner = t } | t <- shrink $ owner p ]
-  --}
+
+  shrink p = (if isNothing (description p) then [] else [p { description = Nothing }]) ++
+             (if isNothing (url p) then [] else [p { url = Nothing }]) ++
+             (if isNothing (owner p) then [] else [p { owner = Nothing }])
 
 instance Arbitrary Status where
 
@@ -31,11 +28,7 @@ instance Arbitrary Status where
   shrink _    = [Done]
 
 testingKeys ∷ [String]
---testingKeys = ["a","b","c","d"]
-testingKeys = ["a"]
-
-rootKey ∷ String
-rootKey = "root"
+testingKeys = ["a", "b", "c", "d"]
 
 instance Arbitrary ProjectSystem where
 
@@ -77,11 +70,7 @@ instance Arbitrary Project where
                   , (1, SequenceProj <$> scale shrinkFactor arbitrary)
                   , (2, RefProj <$> elements testingKeys) ]
 
-  shrink p = let p' = simplifyProj p in if p == p' then [] else [p]
-  -- shrink (SumProj (p NE.:| []))      = [p]
-  -- shrink (ProductProj (p NE.:| []))  = [p]
-  -- shrink (SequenceProj (p NE.:| [])) = [p]
-  -- shrink (SumProj ps)      = map SumProj (shrink ps) ++ NE.toList ps
-  -- shrink (ProductProj ps)  = map ProductProj (shrink ps) ++ NE.toList ps
-  -- shrink (SequenceProj ps) = map SequenceProj (shrink ps) ++ NE.toList ps
-  -- shrink (RefProj _)       = []
+  shrink (SumProj ps)      = NE.toList ps
+  shrink (ProductProj ps)  = NE.toList ps
+  shrink (SequenceProj ps) = NE.toList ps
+  shrink (RefProj _)       = []