next, need to fix the tests because expanded RegRule.

mengwong/mp/src/Lib.hs

@@ -48,7 +48,7 @@ someFunc = do
 
 -- TODO: integrate debugging and callstack depth with the runConfig, thread it through all the functions here
 -- printf debugging infrastructure
-debuggery = False
+debuggery = True
 myTraceM x = when debuggery (traceM x)
 debugPrint depth str = when debuggery $ do
   lookingAt <- lookAhead (getToken :: Parser MyToken)
@@ -297,12 +297,13 @@ pRegRule depth = try (pRegRuleSugary depth) <|> pRegRuleNormal depth
 -- "You MAY" has no explicit PARTY or EVERY keyword
 pRegRuleSugary :: Depth -> Parser [Rule]
 pRegRuleSugary depth = do
+  debugPrint depth "pRegRuleSugary"
   entitytype         <- pOtherVal <* dnl
   leftX              <- lookAhead pXLocation -- this is the column where we expect IF/AND/OR etc.
   deontic            <- pDeontic <* dnl
   temporal           <- optional pTemporal
   rulebody           <- permutations depth
-  let (who, (ands, brs)) = fromMaybe (Always, (AA.Leaf "always", [])) (listToMaybe $ rbpbrs rulebody) -- if there is no WHO line
+  let (who, (ands, brs)) = mergePBRS (if null (rbpbrs rulebody) then [(Always, (AA.Leaf "always", []))] else rbpbrs rulebody)
       toreturn = Regulative
                  entitytype
                  (AA.Leaf "unit")
@@ -322,6 +323,7 @@ pRegRuleSugary depth = do
 
 pRegRuleNormal :: Depth -> Parser [Rule]
 pRegRuleNormal depth = do
+  debugPrint depth "pRegRuleNormal"
   leftX              <- lookAhead pXLocation -- this is the column where we expect IF/AND/OR etc.
   guard $ leftX >= depth
   (party_every, entitytype)   <- pActor Party <|> pActor Every
@@ -332,7 +334,7 @@ pRegRuleNormal depth = do
   -- deontic            <- pDeontic                                                <* dnl
   -- temporal           <- optional pTemporal
   -- action             <- pAction
-  let (who, (cbs, brs)) = mergePBRS $ rbpbrs rulebody
+  let (who, (cbs, brs)) = mergePBRS (if null (rbpbrs rulebody) then [(Always, (AA.Leaf "always", []))] else rbpbrs rulebody)
   let (ewho, (ebs, ebrs)) = fromMaybe (Always, (AA.Leaf "always", [])) whoBool
   let toreturn = Regulative
                  entitytype
@@ -344,13 +346,16 @@ pRegRuleNormal depth = do
   myTraceM $ "pRegRule: the specifier is " ++ show who
   myTraceM $ "pRegRule: returning " ++ show toreturn
   return ( toreturn : brs )
-  where
-    mergePBRS :: [(Preamble, BoolRules)] -> (Preamble, BoolRules)
-    mergePBRS xs =
-      let (w,(a,b)) = head xs
-          pre_a = fst . snd <$> tail xs
-      in (w,( a <> mconcat pre_a
-            ,      concat (b : (snd . snd <$> tail xs) )))
+
+mergePBRS :: [(Preamble, BoolRules)] -> (Preamble, BoolRules)
+mergePBRS xs =
+  let (w,(a,b)) = head xs
+      pre_a = fst . snd <$> tail xs
+      toreturn = (w,( a <> mconcat pre_a
+                    ,      concat (b : (snd . snd <$> tail xs) )))
+  in trace ("mergePBRS: called with " ++ show xs)
+     trace ("mergePBRS: about to return " ++ show toreturn)
+     toreturn
 
 pTemporal :: Parser (TemporalConstraint Text.Text)
 pTemporal = do
@@ -388,13 +393,16 @@ data RuleBody = RuleBody { rbpbrs     :: [(Preamble, BoolRules)] -- not subject
                       deriving (Semigroup, Monoid) via Generically RuleBody
 
 permutations :: Depth -> Parser RuleBody
-permutations depth =
-  permute ((\a b c d -> mconcat [a,b,c,d])
-           <$$> ( (\a -> RuleBody a [] [] [])   <$> many (preambleBoolRules depth) <* dnl ) -- WHO xxx, IF yyy
-           <||> ( (\a -> RuleBody [] [a] [] []) <$> pAction depth )
-           <||> ( (\a -> RuleBody [] [] [a] []) <$> pDeontic )
-           <|?> ( mempty, (\a -> RuleBody [] [] [] [a]) <$> pTemporal )
-          )
+permutations depth = do
+  toreturn <- permute ((\a b c d -> mconcat [a,b,c,d])
+                        <$$> ( (\a -> RuleBody [] [a] [] []) <$> pAction depth )
+                        <||> ( (\a -> RuleBody a [] [] [])   <$> many (preambleBoolRules depth) <* dnl ) -- WHO xxx, IF yyy
+                        <||> ( (\a -> RuleBody [] [] [a] []) <$> pDeontic )
+                        <|?> ( mempty, (\a -> RuleBody [] [] [] [a]) <$> pTemporal )
+                      )
+  myTraceM $ "permutations: about to return"
+  myTraceM $ show toreturn
+  return toreturn
 
 newPre :: Text.Text -> AA.Item Text.Text -> AA.Item Text.Text
 newPre t (AA.Leaf x) = AA.Leaf x

mengwong/mp/test/Spec.hs

@@ -24,7 +24,7 @@ main = hspec $ do
             every = "person"
             , who = Any ( Pre "Always" ) [ ]
             , deontic = DMust
-            , action = "sing"
+            , action = ("sing",[])
             , temporal = Nothing
             } ]
 
@@ -35,7 +35,7 @@ main = hspec $ do
             every = "person"
             , who = Leaf "walks"
             , deontic = DMust
-            , action = "sing"
+            , action = ("sing",[])
             , temporal = Nothing
             } ]
 
@@ -55,7 +55,7 @@ main = hspec $ do
                 ]
               ]
             , deontic = DMust
-            , action = "sing"
+            , action = ("sing", [])
             , temporal = Nothing
             } ]
 
@@ -71,7 +71,7 @@ main = hspec $ do
                              , Leaf "swallows" ]
                            ]
                          , deontic = DMust
-                         , action = "sing"
+                         , action = ("sing", [])
                          , temporal = Nothing
                          } ]
 
@@ -109,7 +109,7 @@ main = hspec $ do
                                 , Leaf "degustates"
                                 ]
                         , deontic = DMust
-                        , action = "sing"
+                        , action = ("sing", [])
                         , temporal = Nothing
                         }
                       , Constitutive