parser and identity backend

Wrote a parser and a backend that spits out parseable input

.ghci

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

.stylish-haskell.yaml

@@ -201,4 +201,3 @@ newline: lf
 
 language_extensions:
    - UnicodeSyntax
-   - OverloadedStrings

app/Main.hs

@@ -1,4 +1,12 @@
+{-# LANGUAGE UnicodeSyntax #-}
 module Main where
 
-main :: IO ()
-main = putStrLn $ "hello " ++ "world"
+import           MasterPlan.Backend.Identity
+import           MasterPlan.Parser
+
+main ∷ IO ()
+main = do let filename = "master.plan"
+          contents <- readFile filename
+          case runParser filename contents of
+            Left e  -> putStr e
+            Right v -> putStr $ render v

master-plan.cabal

@@ -20,8 +20,7 @@ executable master-plan
   main-is:             Main.hs
   default-language:    Haskell2010
   ghc-options:         -Wall
-  default-extensions:  OverloadedStrings
-                     , UnicodeSyntax
+  default-extensions:  UnicodeSyntax
   build-depends:       base
                      , master-plan
                      , optparse-applicative
@@ -30,12 +29,14 @@ library
     hs-source-dirs:      src
     default-language:    Haskell2010
     ghc-options:         -Wall
-    default-extensions:  OverloadedStrings
-                       , UnicodeSyntax
+    default-extensions:  UnicodeSyntax
     build-depends:       base
-                       , megaparsec
+                       , megaparsec == 6.0.*
                        , containers
-    exposed-modules:   MasterPlan.Data
+                       , mtl
+    exposed-modules:     MasterPlan.Data
+                       , MasterPlan.Parser
+                       , MasterPlan.Backend.Identity
 
 test-suite spec
   type:             exitcode-stdio-1.0
@@ -51,3 +52,5 @@ test-suite spec
                   , hspec
                   , QuickCheck
   other-modules:    MasterPlan.DataSpec
+                  , MasterPlan.Arbitrary
+                  , MasterPlan.ParserSpec

master.plan

@@ -0,0 +1,10 @@
+
+owner(root) = "rsetti";
+
+root = a + b;
+
+name(a) = "howdy";
+
+description(a) = "hello world!";
+
+status(b) = done;

src/MasterPlan/Backend/Identity.hs

@@ -0,0 +1,73 @@
+{-# LANGUAGE UnicodeSyntax #-}
+module MasterPlan.Backend.Identity (render) where
+
+import           Control.Monad.RWS
+import           Data.Char          (toLower)
+import           Data.List          (intercalate)
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Map           as M
+import           Data.Maybe         (fromMaybe)
+import           MasterPlan.Data
+
+-- |Plain text renderer
+render ∷ ProjectSystem → String
+render (ProjectSystem bs) = snd $ evalRWS (renderName "root") () bs
+
+type RenderMonad = RWS () String (M.Map String ProjectBinding)
+
+renderLine ∷ String → RenderMonad ()
+renderLine s = tell s >> tell ";\n"
+
+renderName ∷ String → RenderMonad ()
+renderName projName =
+  do mb <- gets $ M.lookup projName
+     case mb of
+       Nothing -> pure ()
+       Just b  -> do renderBinding projName b
+                     tell "\n" -- empty line to separate bindings
+                     modify $ M.delete projName
+                     let names = case b of
+                                  ExpressionProj _ e -> dependencies e
+                                  _                  -> []
+                     mapM_ renderName names
+
+dependencies ∷ Project → [String]
+dependencies (RefProj n)       = [n]
+dependencies (SumProj ps)      = concatMap dependencies ps
+dependencies (SequenceProj ps) = concatMap dependencies ps
+dependencies (ProductProj ps)  = concatMap dependencies ps
+
+renderProps ∷ String → ProjectProperties → RenderMonad ()
+renderProps projName p = do renderProperty projName "name" (title p) "root" id
+                            renderProperty projName "description" (description p) Nothing $ fromMaybe ""
+                            renderProperty projName "url" (url p) Nothing $ fromMaybe ""
+                            renderProperty projName "owner" (owner p) Nothing $ fromMaybe ""
+
+renderProperty ∷ Eq a ⇒ String → String → a → a → (a → String) → RenderMonad ()
+renderProperty projName propName val def toStr
+  | val == def = pure ()
+  | otherwise = renderLine $ propName ++ "(" ++ projName ++ ") = " ++ toStr val
+
+renderBinding ∷ String → ProjectBinding → RenderMonad ()
+renderBinding projName (UnconsolidatedProj p) = renderProps projName p
+renderBinding projName (p@TaskProj {}) =
+    do renderProps projName $ props p
+       renderProperty projName "cost" (reportedCost p) 0 show
+       renderProperty projName "status" (reportedStatus p) Ready (map toLower . show)
+       renderProperty projName "trust" (reportedTrust p) 1 percentage
+       renderProperty projName "progress" (reportedProgress p) 0 percentage
+  where
+    percentage n = show (n * 100) ++ "%"
+
+
+renderBinding projName (ExpressionProj pr e) =
+    do renderProps projName pr
+       renderLine $ projName ++ " = " ++ expressionToStr e
+  where
+    combinedEToStr op ps = let sube = map expressionToStr $ NE.toList ps
+                            in intercalate (" " ++ op ++ " ") sube
+
+    expressionToStr (RefProj n)       = n
+    expressionToStr (ProductProj ps)  = combinedEToStr "*" ps
+    expressionToStr (SequenceProj ps) = combinedEToStr "->" ps
+    expressionToStr (SumProj ps)      = combinedEToStr "*" ps

src/MasterPlan/Data.hs

@@ -15,10 +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 (NE.NonEmpty Project) |
+               ProductProj (NE.NonEmpty Project) |
+               SequenceProj (NE.NonEmpty Project) |
+               RefProj String
                 deriving (Eq, Show)
 
 -- |A binding of a name can refer to an expression. If there are no
@@ -32,14 +32,15 @@ data ProjectBinding = TaskProj { props            :: ProjectProperties
                                } |
                       ExpressionProj { props      :: ProjectProperties
                                      , expression :: Project
-                                     }
+                                     } |
+                      UnconsolidatedProj { props :: ProjectProperties }
                          deriving (Eq, Show)
 
 -- |Any binding (with a name) may have associated properties
 data ProjectProperties = ProjectProperties { title       :: String
-                                           , description :: Maybe[String]
-                                           , url         :: Maybe[String]
-                                           , owner       :: Maybe[String]
+                                           , description :: Maybe String
+                                           , url         :: Maybe String
+                                           , owner       :: Maybe String
                                            } deriving (Eq, Show)
 
 -- |A project system defines the bindins (mapping from names to expressions or tasks)
@@ -53,8 +54,18 @@ defaultProjectProps = ProjectProperties { title = "root"
                                         , url = Nothing
                                         , owner = Nothing }
 
+defaultTaskProj ∷ ProjectBinding
+defaultTaskProj = TaskProj { props = defaultProjectProps
+                           , reportedCost = 0
+                           , reportedTrust = 1
+                           , reportedProgress = 0
+                           , reportedStatus = Ready }
+
 isOpen ∷ ProjectSystem → Project → Bool
-isOpen sys p = status sys p `elem` [InProgress, Ready, Blocked]
+isOpen sys p =
+   status sys p `elem` openStatus
+  where
+   openStatus = [InProgress, Ready, Blocked] :: [Status]
 
 isClosed ∷ ProjectSystem → Project → Bool
 isClosed sys p = not $ isOpen sys p
@@ -65,6 +76,7 @@ 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
+    Just (UnconsolidatedProj _)         → 0 -- default
     Nothing                             -> 0 -- should not happen
 cost sys (SequenceProj ps) = costConjunction sys $ NE.dropWhile (isClosed sys) ps
 cost sys (ProductProj ps) = costConjunction sys $ NE.filter (isOpen sys) ps
@@ -88,6 +100,7 @@ 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
+    Just (UnconsolidatedProj _)         → 1 -- default
     Nothing                             -> 0 -- should not happen
 trust sys (SequenceProj ps) = trustConjunction sys $ NE.dropWhile (isClosed sys) ps
 trust sys (ProductProj ps) = trustConjunction sys $ NE.filter (isOpen sys) ps
@@ -106,6 +119,7 @@ progress sys (RefProj n) =
     Just TaskProj { reportedStatus=Done } -> 1
     Just TaskProj { reportedProgress=p }  -> p
     Just ExpressionProj { expression=p}   -> progress sys p -- TODO: avoid cyclic
+    Just (UnconsolidatedProj _)           → 0 -- default
     Nothing                               -> 0 -- should not happen
 progress sys (SequenceProj ps)   = progressConjunction sys ps
 progress sys (ProductProj ps)    = progressConjunction sys ps
@@ -123,6 +137,7 @@ 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
+    Just (UnconsolidatedProj _)         → Ready -- default
     Nothing                                        -> Cancelled -- should not happen
 status sys (SequenceProj ps) =
   let rest = NE.dropWhile (isClosed sys) ps

src/MasterPlan/Parser.hs

@@ -0,0 +1,172 @@
+{-# LANGUAGE UnicodeSyntax #-}
+{-# LANGUAGE OverloadedLists #-}
+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)
+import           Text.Megaparsec.Char
+import qualified Text.Megaparsec.Char.Lexer as L
+import           Text.Megaparsec.Expr
+
+{-
+* Grammar
+
+definition = project_def | predicate_def
+
+project_def = identifier "=" expression
+expression = term ((">>" | "x") term)*
+term = factor ("+" factor)*
+factor = "(" expression ")" | identifier
+
+predicate_def = identifier "(" identifier ")" "=" value
+value = number | text
+-}
+
+type Parser = ParsecT Void String (State ProjectSystem)
+
+-- |Space consumer
+sc ∷ Parser ()
+sc = L.space space1 lineCmnt blockCmnt
+  where
+    lineCmnt  = L.skipLineComment "//"
+    blockCmnt = L.skipBlockComment "/*" "*/"
+
+lexeme ∷ Parser a → Parser a
+lexeme = L.lexeme sc
+
+symbol ∷ String → Parser String
+symbol = L.symbol sc
+
+-- | 'parens' parses something between parenthesis.
+parens ∷ Parser a → Parser a
+parens = between (symbol "(") (symbol ")")
+
+-- |list of reserved words
+rws ∷ [String]
+rws = ["name", "description", "url", "owner", "status", "progress", "cost", "risk"]
+
+identifier ∷ Parser String
+identifier = (lexeme . try) (p >>= check)
+  where
+    p       = (:) <$> letterChar <*> many alphaNumChar
+    check x = if x `elem` rws
+                then fail $ "keyword " ++ show x ++ " cannot be an identifier"
+                else return x
+
+stringLiteral :: Parser String
+stringLiteral = char '"' >> manyTill L.charLiteral (char '"')
+
+statusParser :: Parser Status
+statusParser = choice ([ symbol "ready" *> pure Ready
+                       , symbol "blocked" *> pure Blocked
+                       , symbol "progress" *> pure InProgress
+                       , symbol "done" *> pure Done
+                       , symbol "cancelled" *> pure Cancelled ] :: [Parser Status])
+
+percentage :: Parser Float
+percentage = do n <- L.float <* symbol "%"
+                pure $ n / 100
+
+nonNegativeNumber :: Parser Float
+nonNegativeNumber = L.float
+
+definition ∷ Parser ()
+definition =
+    choice ([ propsProp "name" stringLiteral (\v p -> p { title = v })
+            , propsProp "description" stringLiteral (\v p -> p { description = Just v})
+            , propsProp "url" stringLiteral (\v p -> p { url = Just v})
+            , propsProp "owner" stringLiteral (\v p -> p { owner = Just v})
+            , taskProp "status" statusParser (\v b -> case b of t@TaskProj {} -> t { reportedStatus = v }; _ -> b)
+            , taskProp "progress" percentage (\v b -> case b of t@TaskProj {} -> t { reportedProgress = v }; _ -> b)
+            , taskProp "cost" nonNegativeNumber (\v b -> case b of t@TaskProj {} -> t { reportedCost = v }; _ -> b)
+            , taskProp "trust" percentage (\v b -> case b of t@TaskProj {} -> t { reportedTrust = v }; _ -> b)
+            , structure ] :: [Parser ()])
+  where
+    structure :: Parser ()
+    structure = do projName <- identifier
+                   projectExpr <- symbol "=" *> expressionParser
+                   binding <- lift $ gets $ M.lookup projName . bindings
+                   newBinding <- case binding of
+                                   Nothing -> pure $ ExpressionProj (defaultProjectProps { title=projName }) projectExpr
+                                   Just ExpressionProj {} -> fail $ "Redefinition of \"" ++ projName ++ "\"."
+                                   Just (UnconsolidatedProj p) -> pure $ ExpressionProj p projectExpr
+                                   Just TaskProj {} -> fail $ "Project \"" ++ projName ++ "\" is atomic"
+                   lift $ modify (\sys -> sys { bindings = M.insert projName newBinding $ bindings sys })
+
+    propsProp :: String -> Parser a -> (a -> ProjectProperties -> ProjectProperties) -> Parser ()
+    propsProp propName valueParser modifier =
+       property propName valueParser setter
+     where
+       setter projName val Nothing = pure $ UnconsolidatedProj $ modifier val $ defaultProjectProps { title=projName }
+       setter _ val (Just p) = pure $ p { props = modifier val $ props p}
+
+    taskProp :: String -> Parser a -> (a -> ProjectBinding -> ProjectBinding) -> Parser ()
+    taskProp propName valueParser modifier =
+       property propName valueParser setter
+     where
+       setter projName val Nothing = pure $ modifier val $ defaultTaskProj { props = defaultProjectProps { title=projName }}
+       setter projName _ (Just ExpressionProj {}) = fail $ "Project \"" ++ projName ++ "\" is not atomic."
+       setter _ val (Just (UnconsolidatedProj p)) = pure $ modifier val $ defaultTaskProj { props=p }
+       setter _ val (Just p@TaskProj {}) = pure $ modifier val p
+
+    property ∷ String → Parser a → (String -> a -> Maybe ProjectBinding -> Parser ProjectBinding) -> Parser ()
+    property propName valueParser setter = do _ <- symbol propName
+                                              projName <- parens identifier
+                                              mBinding <- lift $ do b <- gets bindings
+                                                                    pure $ M.lookup projName b
+                                              value <- symbol "=" *> valueParser
+                                              newBinding <- setter projName value mBinding
+                                              let modifySys :: ProjectSystem -> ProjectSystem
+                                                  modifySys sys = sys { bindings = M.insert projName newBinding $ bindings sys }
+                                              lift $ modify modifySys
+
+expressionParser ∷ Parser Project
+expressionParser =
+    makeExprParser term table <?> "expression"
+  where
+    term = parens expressionParser <|> (RefProj <$> identifier)
+    table = [[binary "*" combineProduct]
+            ,[binary "->" combineSequence]
+            ,[binary "+" combineSum]]
+    binary  op f = InfixL  (f <$ symbol op)
+
+    combineProduct ∷ Project → Project → Project
+    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 (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 (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."
+       pure ps
+ where
+   definitionSeq = void $ endBy1 definition (symbol ";")
+
+
+runParser :: String -> String -> Either String ProjectSystem
+runParser filename contents = let mr = runParserT projectSystem filename contents
+                                  initialPS = ProjectSystem M.empty
+                              in case evalState mr initialPS of
+                                    Left e -> Left $ parseErrorTextPretty e
+                                    Right v -> Right v

stack.yaml

@@ -39,7 +39,8 @@ packages:
 - '.'
 # Dependency packages to be pulled from upstream that are not in the resolver
 # (e.g., acme-missiles-0.3)
-extra-deps: []
+extra-deps:
+  - megaparsec-6.0.2
 
 # Override default flag values for local packages and extra-deps
 flags: {}
@@ -63,4 +64,4 @@ extra-package-dbs: []
 # extra-lib-dirs: [/path/to/dir]
 #
 # Allow a newer minor version of GHC than the snapshot specifies
-# compiler-check: newer-minor
+# compiler-check: newer-minor

test/MasterPlan/Arbitrary.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE UnicodeSyntax #-}
+module MasterPlan.Arbitrary where
+
+import           Control.Monad      (replicateM)
+import           Data.List          (nub)
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Map           as M
+import           MasterPlan.Data
+import           Test.QuickCheck
+
+instance Arbitrary ProjectProperties where
+
+  arbitrary = pure defaultProjectProps
+  {-
+  arbitrary = ProjectProperties <$> arbitrary
+                                <*> arbitrary
+                                <*> arbitrary
+                                <*> arbitrary
+
+  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 ]
+             -}
+
+instance Arbitrary Status where
+
+  arbitrary = elements [ Ready, Blocked, InProgress, Done, Cancelled ]
+
+  shrink Done = []
+  shrink _    = [Done]
+
+testingKeys ∷ [String]
+testingKeys = ["a","b","c","d"]
+
+rootKey ∷ String
+rootKey = "root"
+
+instance Arbitrary ProjectSystem where
+
+  arbitrary = do bs <- replicateM (length testingKeys) arbitrary
+                 let arbitraryExpr = ExpressionProj <$> arbitrary <*> arbitrary
+                 rootB <- frequency [ (1, arbitrary), (10, arbitraryExpr) ]
+                 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 k = case M.lookup k bs of
+        Nothing -> []
+        Just b  -> map (\s -> M.adjust (const s) k bs) $ shrink b
+
+instance Arbitrary ProjectBinding where
+
+  -- NOTE: ProjectBinding arbitrary are always tasks (no expression)
+  --       to avoid generating cycles
+  arbitrary =
+    let unitGen = choose (0.0, 1.0)
+     in frequency [ (50, TaskProj <$> arbitrary
+                                  <*> unitGen
+                                  <*> unitGen
+                                  <*> arbitrary
+                                  <*> unitGen)
+                  , (1, pure $ UnconsolidatedProj defaultProjectProps) ]
+
+  shrink b = nub [ b { reportedCost=0 }
+                 , b { reportedCost=1 }
+                 , b { reportedTrust=0 }
+                 , b { reportedTrust=1 }
+                 , b { reportedStatus=Done } ]
+
+instance Arbitrary Project where
+
+  arbitrary =
+    let shrinkFactor n = 2 * n `quot` 5
+    in  oneof [ SumProj <$> scale shrinkFactor arbitrary
+              , ProductProj <$> scale shrinkFactor arbitrary
+              , SequenceProj <$> scale shrinkFactor arbitrary
+              , RefProj <$> elements testingKeys ]
+
+  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 _)       = []

test/MasterPlan/DataSpec.hs

@@ -1,93 +1,17 @@
 {-# LANGUAGE UnicodeSyntax #-}
 module MasterPlan.DataSpec where
 
-import           Data.Bool           (bool)
-import qualified Data.Map            as M
+import           Data.Bool            (bool)
+import qualified Data.Map             as M
 import           MasterPlan.Data
 import           Test.Hspec
-import           Test.QuickCheck     hiding (sample)
+import           Test.QuickCheck      hiding (sample)
 
-import           Control.Applicative ((<$>), (<*>))
 import           Control.Monad.State
-import           Data.List           (nub)
-import qualified Data.List.NonEmpty  as NE
+import qualified Data.List.NonEmpty   as NE
+import           MasterPlan.Arbitrary
 import           System.Random
 
-instance Arbitrary ProjectProperties where
-
-  arbitrary = pure defaultProjectProps
-{-
-  arbitrary = ProjectProperties <$> arbitrary
-                                <*> arbitrary
-                                <*> arbitrary
-                                <*> arbitrary
-
-  shrink p = [ p { name = t } | t <- shrink $ name p ] ++
-             [ p { description = t } | t <- shrink $ description p ] ++
-             [ p { url = t } | t <- shrink $ url p ] ++
-             [ p { owner = t } | t <- shrink $ owner p ]
--}
-
-instance Arbitrary Status where
-
-  arbitrary = elements [ Ready, Blocked, InProgress, Done, Cancelled ]
-
-  shrink Done = []
-  shrink _    = [Done]
-
-testingKeys ∷ [String]
-testingKeys = ["a","b","c","d"]
-
-rootKey ∷ String
-rootKey = "root"
-
-instance Arbitrary ProjectSystem where
-
-  arbitrary = do bs <- replicateM (length testingKeys) arbitrary
-                 let arbitraryExpr = ExpressionProj <$> arbitrary <*> arbitrary
-                 rootB <- frequency [ (1, arbitrary), (10, arbitraryExpr) ]
-                 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 k = case M.lookup k bs of
-        Nothing -> []
-        Just b  -> map (\s -> M.adjust (const s) k bs) $ shrink b
-
-instance Arbitrary ProjectBinding where
-
-  -- NOTE: ProjectBinding arbitrary are always tasks (no expression)
-  --       to avoid generating cycles
-  arbitrary =
-    let unitGen = choose (0.0, 1.0)
-     in TaskProj <$> arbitrary
-                 <*> unitGen
-                 <*> unitGen
-                 <*> 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 =
-    let shrinkFactor n = 2 * n `quot` 5
-    in  oneof [ SumProj <$> scale shrinkFactor arbitrary
-              , ProductProj <$> scale shrinkFactor arbitrary
-              , SequenceProj <$> scale shrinkFactor arbitrary
-              , RefProj <$> elements testingKeys ]
-
-  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 _)       = []
-
 average ∷ RandomGen g ⇒ State g Float → Int → State g Float
 average sample n = do total <- replicateM n sample
                       pure $ sum total / fromIntegral n
@@ -99,11 +23,12 @@ simulate sys (RefProj n) =
        do r <- state $ randomR (0, 1)
           pure (t > r, c)
      Just ExpressionProj { expression=p} -> simulate sys p -- TODO: avoid cyclic
+     Just (UnconsolidatedProj _)         -> pure (True, 0)
      Nothing                             -> pure (False, 0) -- should not happen
 
-simulate sys SequenceProj { subprojects=ps }   = simulateConjunction sys $ NE.dropWhile (isClosed sys) ps
-simulate sys ProductProj { subprojects=ps }    = simulateConjunction sys $ NE.filter (isOpen sys) ps
-simulate sys SumProj { subprojects=ps }        =
+simulate sys (SequenceProj ps)   = simulateConjunction sys $ NE.dropWhile (isClosed sys) ps
+simulate sys (ProductProj ps)    = simulateConjunction sys $ NE.filter (isOpen sys) ps
+simulate sys (SumProj ps)        =
   if null opens then pure (True, 0) else simulate' opens
  where
    opens = NE.filter (isOpen sys) ps

test/MasterPlan/ParserSpec.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE UnicodeSyntax #-}
+module MasterPlan.ParserSpec where
+
+import           MasterPlan.Arbitrary ()
+import           MasterPlan.Backend.Identity (render)
+import           MasterPlan.Data
+import           MasterPlan.Parser           (runParser)
+import           Test.Hspec
+import           Test.QuickCheck
+
+spec ∷ Spec
+spec =
+  describe "parser" $
+
+    it "identity backend output should parse into the same input" $ do
+      let propertyParseAndOutputIdentity ∷ ProjectSystem → Property
+          propertyParseAndOutputIdentity sys =
+            runParser "test" (render sys) === Right sys
+
+      property propertyParseAndOutputIdentity