Merge pull request #404 from smucclaw/20230721-prolog-semantics

add support for s-expressions and for WHERE limbs in DECIDE

lib/haskell/natural4/.ghci

@@ -1,4 +1,4 @@
 :set -isrc
 -- Don't spam a ton of warnings
 -- :set -Wno-incomplete-patterns -Wno-unused-imports -Wno-name-shadowing -Wno-unused-top-binds -Wno-missing-signatures
-:l src/LS.hs app/Main.hs
+:l src/LS.hs test/Spec.hs

lib/haskell/natural4/src/LS/BasicTypes.hs

@@ -80,7 +80,8 @@ data MyToken = Every | Party | TokAll
              | Empty | EOL
              | RuleMarker Int Text.Text
              | Expect | ScenarioTok
-             | TokLT | TokLTE | TokGT | TokGTE | TokIn | TokNotIn | TokEQ
+             | TokLT | TokLTE | TokGT | TokGTE | TokIn | TokNotIn | TokEQ | TokAnd | TokOr | TokSum | TokProduct
+             | Notwithstanding | Despite | SubjectTo
              | Otherwise
              | SOF | EOF
              | GoDeeper | UnDeeper
@@ -240,16 +241,27 @@ toToken "§§§§§§"    = pure $ RuleMarker   6  "§"
 toToken "SCENARIO"  = pure ScenarioTok
 toToken "EXPECT"    = pure Expect
 toToken "<"         = pure TokLT
+toToken "MIN"       = pure TokLT;      toToken "MIN OF"    = pure TokLT
 toToken "=<"        = pure TokLTE
 toToken "<="        = pure TokLTE
 toToken ">"         = pure TokGT
+toToken "MAX"       = pure TokGT;      toToken "MAX OF"    = pure TokGT
 toToken ">="        = pure TokGTE
 toToken "="         = pure TokEQ
+toToken "&&"        = pure TokAnd
+toToken "||"        = pure TokOr
+toToken "SUM"       = pure TokSum;     toToken "SUM OF"     = pure TokSum
+toToken "PRODUCT"   = pure TokProduct; toToken "PRODUCT OF" = pure TokProduct
 toToken "=="        = pure TokEQ
 toToken "==="       = pure TokEQ
 toToken "IN"        = pure TokIn
 toToken "NOT IN"    = pure TokNotIn
 
+-- rule priority interactions and "defeasibility"
+toToken "SUBJECT TO" = pure SubjectTo
+toToken "DESPITE"    = pure Despite
+toToken "NOTWITHSTANDING" = pure Notwithstanding
+
 toToken "OTHERWISE" = pure Otherwise
 
 toToken "WHERE"     = pure Where
@@ -376,6 +388,8 @@ renderToken :: MyToken -> String
 renderToken ScenarioTok = "SCENARIO"
 renderToken TokAll = "ALL"
 renderToken MPNot = "NOT"
+renderToken TokAnd = "&&"
+renderToken TokOr  = "||"
 renderToken TokLT = "<"
 renderToken TokLTE = "<="
 renderToken TokGT = ">"
@@ -399,6 +413,10 @@ renderToken (RuleMarker n txt) = concat $ replicate n (Text.unpack txt)
 
 renderToken Semicolon = ";;"
 
+renderToken SubjectTo = "SUBJECT TO"
+renderToken TokSum = "SUM"
+renderToken TokProduct = "PRODUCT"
+
 renderToken tok = map toUpper (show tok)
 
 liftMyToken :: [String] -> MyToken -> WithPos MyToken

lib/haskell/natural4/src/LS/Interpreter.hs

@@ -613,7 +613,9 @@ bsr2bsmt (AA.Leaf (RPBoolStructR  mt1  rpr bsr2) ) = let output = (\(RPMT rpmt)
                                                      in -- trace ("bsr2bsmt handling a boolstructr, input = " <> show bsr2) $
                                                         -- trace ("bsr2bsmt handling a boolstructr, returning " <> show output) $
                                                         output
-bsr2bsmt (AA.Leaf (RPnary     _rprel rp) )         = AA.mkLeaf rp
+bsr2bsmt (AA.Leaf (RPnary     RPgt rps) )          = AA.mkAll (Just $ AA.Pre "max of:") (bsr2bsmt . AA.Leaf <$> rps)
+bsr2bsmt (AA.Leaf (RPnary     RPlt rps) )          = AA.mkAll (Just $ AA.Pre "min of:") (bsr2bsmt . AA.Leaf <$> rps)
+bsr2bsmt (AA.Leaf (RPnary     _rprel rps) )        = bsr2bsmt (AA.All Nothing (AA.Leaf <$> rps))
 bsr2bsmt (AA.All lbl xs) = AA.mkAll lbl (bsr2bsmt <$> xs)
 bsr2bsmt (AA.Any lbl xs) = AA.mkAny lbl (bsr2bsmt <$> xs)
 bsr2bsmt (AA.Not     x ) = AA.mkNot     (bsr2bsmt x)

lib/haskell/natural4/src/LS/PrettyPrinter.hs

@@ -44,7 +44,7 @@ instance Pretty RelationalPredicate where
   pretty (RPMT          mt)            = snake_join mt
   pretty (RPConstraint  mt1 rprel mt2) = hsep [ snake_join mt1, pretty (rel2op rprel), snake_join mt2 ]
   pretty (RPBoolStructR mt1 rprel bsr) = hsep [ snake_join mt1, pretty rprel, pretty bsr ]
-  pretty (RPnary rprel rp)             = hsep [ pretty rprel, pretty rp ]
+  pretty (RPnary rprel rps)            = hsep [ pretty rprel, pretty rps ]
 
 -- Hornlike rule transformations -- these form HC2 situations
 -- 1   p investment IS savings                     WHEN blah => if blah then investment p savings
@@ -84,7 +84,7 @@ inPredicateForm (RPConstraint  mt1 RPhas mt2)     = addHas (pred_flip mt2) ++ mt
     addHas [] = []
 inPredicateForm (RPConstraint  mt1 rprel mt2)     = MTT (rel2txt rprel) : mt1 ++ mt2
 inPredicateForm (RPBoolStructR mt1 _rprel bsr)    = mt1 ++ concatMap DF.toList (DT.traverse inPredicateForm bsr)
-inPredicateForm (RPnary        rprel rp)          = MTT (rel2txt rprel) : inPredicateForm rp
+inPredicateForm (RPnary        rprel rps)         = MTT (rel2txt rprel) : concatMap inPredicateForm rps
 
 pred_flip :: [a] -> [a]
 pred_flip xs = last xs : init xs

lib/haskell/natural4/src/LS/RelationalPredicates.hs

@@ -211,7 +211,7 @@ import Control.Monad.Writer.Lazy
 import Data.Foldable qualified as DF
 import Data.List.NonEmpty (NonEmpty (..), fromList, nonEmpty, toList)
 import Data.List.NonEmpty qualified as NE
-import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList)
+import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList, isNothing)
 import Data.Semigroup (sconcat)
 import Data.Text qualified as T
 import LS.Parser
@@ -231,22 +231,30 @@ pRelationalPredicate = pRelPred
 -- can we rephrase this as Either or Maybe so we only accept certain tokens as RPRels?
 tok2rel :: Parser RPRel
 tok2rel = choice
-    [ RPis      <$ pToken Is
+    [ parseIS
     , RPhas     <$ pToken Has
     , RPeq      <$ pToken TokEQ
-    , RPlt      <$ pToken TokLT
+    , RPand     <$ pToken TokAnd
+    , RPor      <$ pToken TokOr
+    , RPsum     <$ pToken TokSum
+    , RPproduct <$ pToken TokProduct
+    , RPlt      <$ pToken TokLT    -- serves double duty as MinOflist when in RPnary position
     , RPlte     <$ pToken TokLTE
-    , RPgt      <$ pToken TokGT
+    , RPgt      <$ pToken TokGT    -- serves double duty as MaxOflist when in RPnary position
     , RPgte     <$ pToken TokGTE
     , RPelem    <$ pToken TokIn
     , RPnotElem <$ pToken TokNotIn
+    , RPsubjectTo <$ pToken SubjectTo
     , RPTC TBefore <$ pToken Before
     , RPTC TAfter  <$ pToken After
     , RPTC TBy     <$ pToken By
     , RPTC TOn     <$ pToken On
     , RPTC TVague  <$ pToken Eventually
     ]
 
+parseIS :: Parser RPRel
+parseIS = RPis      <$ pToken Is
+
 rpConstitutiveAsElement :: Rule -> BoolStructR
 rpConstitutiveAsElement = multiterm2bsr
 
@@ -299,7 +307,7 @@ aaLeavesFilter f (AA.Leaf rp) = if f rp then rp2mts rp else []
     rp2mts (RPParamText    pt)           = [pt2multiterm pt]
     rp2mts (RPConstraint  _mt1 _rpr mt2) = [mt2]
     rp2mts (RPBoolStructR _mt1 _rpr bsr) = aaLeavesFilter f bsr
-    rp2mts (RPnary        _rprel rps)    = [rp2mt rps]
+    rp2mts (RPnary        _rprel rps)    = rp2mt <$> rps
 
 
 -- this is probably going to need cleanup
@@ -433,25 +441,36 @@ pHornlike' needDkeyword = debugName ("pHornlike(needDkeyword=" <> show needDkeyw
   let dKeyword = if needDkeyword
                  then Just <$> choice [ pToken Decide ]
                  else Nothing <$ pure ()
-  let permutepart = debugName "pHornlike / permute" $ permute $                         (,,,,)
+  let permutepart = debugName "pHornlike / permute" $ permute $                         (,,,,,)
         <$$> -- (try ambitious <|> -- howerever, the ambitious parser is needed to handle "WHERE  foo IS bar" inserting a hornlike after a regulative.
                someStructure dKeyword -- we are trying to keep things more regular. to eliminate ambitious we need to add the unless/and/or machinery to someStructure, unless the pBSR is equal to it
              -- )
         <|?> (Nothing, Just . snd <$> givenLimb)
         <|?> (Nothing, Just . snd <$> givethLimb)
         <|?> (Nothing, Just . snd <$> uponLimb)
         <|?> (Nothing, whenCase)
+        <|?> ([], mkWhere <$> someStructure (Just <$> pToken wKeyword))
         -- [TODO] refactor the rule-label logic to allow outdentation of rule label line relative to main part of the rule
-  ((keyword, name, clauses), given, giveth, upon, topwhen) <- permutepart
+  ( (keyword, name, clauses)
+    , given, giveth, upon, topwhen
+    , wwhere ) <- permutepart
   return $ defaultHorn { name = name
                        , super = Nothing -- [TODO] need to extract this from the DECIDE line -- can we involve a 'slAka' somewhere downstream?
                        , keyword = fromMaybe Means keyword
                        , given = given
                        , giveth
                        , clauses = addWhen topwhen clauses
                        , upon = upon, rlabel = rlabel
+                       , wwhere = wwhere
+                       -- [TODO] attach srcrefs to the inner WHERE bindings; test for allowing multiple WHERE statements
                        }
   where
+    wKeyword = Where
+    mkWhere (whereKeyword, whereName, whereClauses) = 
+      [ defaultHorn { name    = whereName
+                    , keyword = fromMaybe wKeyword whereKeyword
+                    , clauses = whereClauses } ]
+
     addWhen :: Maybe BoolStructR -> [HornClause2] -> [HornClause2]
     addWhen mbsr hcs = [ -- trace ("addWhen running, appending to hBody = " <> show (hBody hc2)) $
                          -- trace ("addWhen running, appending the mbsr " <> show mbsr) $
@@ -486,14 +505,15 @@ pHornlike' needDkeyword = debugName ("pHornlike(needDkeyword=" <> show needDkeyw
     --   WHEN Z IS Q
 
     --        X IS Y WHEN Z IS Q -- samelinewhen
-    someStructure dKeyword = debugName "pHornlike/someStructure" $ do
-      keyword <- dKeyword -- usually testing for pToken Define or Decide or some such, but sometimes it's not needed, so dKeyword is a Nothing parser
-      relwhens <- (if keyword == Nothing then manyIndentation else someIndentation) $ sameDepth rpSameNextLineWhen
-      return (keyword
-             , inferRuleName (fst . head $ relwhens)
-             , [HC relPred whenpart
-               | (relPred, whenpart) <- relwhens ])
-
+    someStructure :: Parser (Maybe MyToken) -> Parser (Maybe MyToken, RuleName, [HornClause BoolStructR])
+    someStructure dKeyword = do
+      keyword  <- dKeyword -- usually testing for pToken Define or Decide or some such, but sometimes it's not needed, so dKeyword is a Nothing parser
+      debugName ("pHornlike/someStructure(" ++ show keyword ++ ")" ) $ do
+        relwhens <- (if isNothing keyword then manyIndentation else someIndentation) $ sameDepth rpSameNextLineWhen
+        return (keyword
+               , inferRuleName (fst . head $ relwhens)
+               , [HC relPred whenpart
+                 | (relPred, whenpart) <- relwhens ])
 
     givenLimb  = debugName "pHornlike/givenLimb"  $ preambleParamText [Given]
     givethLimb = debugName "pHornlike/givethLimb" $ preambleParamText [Giveth]
@@ -504,7 +524,8 @@ pHornlike' needDkeyword = debugName ("pHornlike(needDkeyword=" <> show needDkeyw
     inferRuleName (RPMT mt)              = mt
     inferRuleName (RPConstraint  mt _ _) = mt
     inferRuleName (RPBoolStructR mt _ _) = mt
-    inferRuleName (RPnary     _rprel rp) = inferRuleName rp
+    inferRuleName (RPnary     _rprel []) = [MTT "unnamed RPnary"]
+    inferRuleName (RPnary     _rprel rp) = inferRuleName (head rp)
 
 rpSameNextLineWhen :: Parser (RelationalPredicate, Maybe BoolStructR)
 rpSameNextLineWhen = slRelPred |&| (fmap join <$> liftSL $ optional whenCase)
@@ -544,8 +565,9 @@ whenIf = debugName "whenIf" $ choice [ pToken When, pToken If ]
 
 slRelPred :: SLParser RelationalPredicate
 slRelPred = debugName "slRelPred" $ do
-  choice [ try ( debugName "slRelPred/RPConstraint"  rpConstraint )
-         , try ( debugName "slRelPred/RPBoolStructR" rpBoolStructR )
+  choice [ try ( debugName "slRelPred/RPnary from IS" rpISnary )
+         , try ( debugName "slRelPred/RPConstraint"   rpConstraint )
+         , try ( debugName "slRelPred/RPBoolStructR"  rpBoolStructR )
          , try ( debugName "slRelPred/nested simpleHorn" $ RPMT <$> mustNestHorn id id meansIsWhose pBSR slMultiTerm) -- special case, do the mustNestHorn here and then repeat the nonesthorn below.
 
          , try ( debugName "slRelPred/RPParamText (with typesig)" rpParamTextWithTypesig )
@@ -586,7 +608,9 @@ rpMT          = RPMT          $*| slAKA slMultiTerm id
 -- | parse an RPConstraint, optionally with an inline MEANS.
 -- we pass to nestedHorn the base parser for RPConstraint, which 
 rpConstraint :: SLParser RelationalPredicate
-rpConstraint  = nestedHorn rpHead id meansIs pBSR (RPConstraint $*| slMultiTerm |>| tok2rel |*| slMultiTerm)
+rpConstraint  = nestedHorn rpHead id meansIs pBSR
+                (RPConstraint $*| slMultiTerm |>| tok2rel |*| slMultiTerm)
+
 
 -- | parse a RelationalPredicate BoolStructR
 rpBoolStructR :: SLParser RelationalPredicate
@@ -597,7 +621,31 @@ rpBoolStructR = debugName "rpBoolStructR calling slMultiTerm / IS / pBSR" $
   |>| debugName "rpBoolStructR/pBSR"        pBSR
 -- then we start with entire relationalpredicates, and wrap them into BoolStructR
 
-
+-- | special case of arithmetic value assignment
+-- @
+--     DECIDE x IS > foo
+--                   bar
+--                   baz
+-- @
+-- This becomes RPnary RPis [RPMT x, RPnary RPgt [RPMT (MTT ["foo"]), RPMT (MTT ["bar"]), RPMT (MTT ["baz"])]]
+
+rpISnary :: SLParser RelationalPredicate
+rpISnary = debugName "rpISnary" $ do
+  (lhs,_rptok,rhs) <- (,,)
+    $*| debugName "rpISnary/slMultiTerm" slMultiTerm
+    |>| parseIS
+    |*| debugName "rpISnary/rpnary" rpNary
+  return $ RPnary RPis [RPMT lhs, rhs]
+
+
+-- | parse a RelationalPredicate RPnary.
+-- Note that once we are in the RPnary universe the subexpressions have to be rpNary or rpMT. No more boolstruct.
+rpNary :: SLParser RelationalPredicate
+rpNary = debugName "rpNary calling rprel / rp" $
+  RPnary
+  $>| debugName "rpNary/tok2rel"     tok2rel
+  |>| debugName "rpNary/some slRelPred"  (some (try (finishSL rpNary) <|> finishSL (liftSL (RPMT <$> pMultiTerm))))
+  -- the finishSL is used to force a rewind to the starting column
 
 -- this used to be in LS/ParamText.hs
 
@@ -955,7 +1003,7 @@ getBSR Regulative{..} = Just $ AA.simplifyBoolStruct $ AA.mkAll Nothing $
             myPrependList pfix nelist = NE.fromList (pfix ++ NE.toList nelist)
         prependToRP ts (RPConstraint  mt1 rpr mt2) = RPConstraint  mt1 rpr ((MTT <$> ts) ++ mt2)
         prependToRP ts (RPBoolStructR mt1 rpr bsr) = RPBoolStructR mt1 rpr (prependToRP ts <$> bsr)
-        prependToRP ts (RPnary        rprel rps)   = RPnary        rprel   (prependToRP ts  $  rps)
+        prependToRP ts (RPnary        rprel rps)   = RPnary        rprel   (prependToRP ts <$> rps)
 
 getBSR _              = Nothing
 

lib/haskell/natural4/src/LS/Rule.hs

@@ -109,7 +109,7 @@ data Rule = Regulative
             , clauses  :: [HornClause2]      -- colour IS blue WHEN fee > $10 ; colour IS green WHEN fee > $20 AND approver IS happy
             , rlabel   :: Maybe RuleLabel
             , lsource  :: Maybe Text.Text
--- [TODO]   , wwhere   :: [Rule]
+            , wwhere   :: [Rule]
             , srcref   :: Maybe SrcRef
             , defaults :: [RelationalPredicate] -- SomeConstant IS 500 ; MentalCapacity TYPICALLY True
             , symtab   :: [RelationalPredicate] -- SomeConstant IS 500 ; MentalCapacity TYPICALLY True
@@ -302,6 +302,7 @@ defaultHorn = Hornlike
   , giveth = Nothing
   , upon  = Nothing
   , clauses = []
+  , wwhere = []
   , rlabel = Nothing
   , lsource = Nothing
   , srcref = dummyRef

lib/haskell/natural4/src/LS/Tokens.hs

@@ -305,7 +305,9 @@ sameOrNextLine pa pb =
 
 -- [TODO] -- are the undeepers above disruptive? we may want a version of the above which stays in SLParser context the whole way through.
 
--- one or more P, monotonically moving to the right, returned in a list
+
+-- | one or more P, monotonically moving to the right, returned in a list.
+-- if you don't want moving to the right, but want the things all to fall at the same indentation level, just use `some` or `many`.
 someDeep :: (Show a) => Parser a -> Parser [a]
 someDeep p = debugName "someDeep"
   ( (:)
@@ -607,7 +609,7 @@ infixl 4 >*|
 
 p1 |>| p2 = do
   l <- p1
-  r <- debugNameSL "|>| calling $>>" $ ($>>) p2
+  r <- debugNameSL "|>| calling $>> to consume goDeeper" $ ($>>) p2
   return (l r)
 infixl 4 |>|
 
@@ -821,7 +823,7 @@ manyIndentation :: (Show a) => Parser a -> Parser a
 manyIndentation p =
   try (debugName "manyIndentation/leaf?" p)
   <|>
-  (debugName "manyIndentation/deeper; calling someIndentation" (try $ someIndentation p))
+  debugName "manyIndentation/deeper; calling someIndentation" (try $ someIndentation p)
 
 manyIndentation' :: Parser a -> Parser a
 manyIndentation' p =
@@ -916,6 +918,10 @@ pAnyText = tok2text <|> pOtherVal
 tok2text :: Parser Text.Text
 tok2text = choice
     [ "IS"     <$ pToken Is
+    , "&&"     <$ pToken TokAnd
+    , "||"     <$ pToken TokOr
+    , "SUM"    <$ pToken TokSum
+    , "PRODUCT"<$ pToken TokProduct
     , "=="     <$ pToken TokEQ
     , "<"      <$ pToken TokLT
     , "<="     <$ pToken TokLTE