20230803 typescript

lib/haskell/natural4/app/Main.hs

@@ -190,7 +190,7 @@ main = do
       (toIntro5FN,  (asShoehorn, asShoehornErr)) = (workuuid <> "/" <> "intro5",   toShoehorn l4i defaultReaderEnv)
       (toIntro6FN,  (asBase,     asBaseErr))     = (workuuid <> "/" <> "intro6",   toBase l4i defaultReaderEnv)
 
-      (totsFN,      asTSstr)                  = (workuuid <> "/" <> "ts",       show (asTypescript rules))
+      (totsFN,      (asTSpretty, asTSerr))    = (workuuid <> "/" <> "ts",       xpLog $ asTypescript l4i)
       (togroundsFN, asGrounds)                = (workuuid <> "/" <> "grounds",  show $ groundrules rc rules)
       (toOrgFN,     asOrg)                    = (workuuid <> "/" <> "org",      toOrg l4i rules)
       (toNL_FN,     asNatLang)                = (workuuid <> "/" <> "natlang",  toNatLang l4i)
@@ -289,7 +289,7 @@ main = do
 
     when (SFL4.toprolog  opts) $ mywritefile  True toprologFN   iso8601 "pl"   asProlog
     when (SFL4.topetri   opts) $ mywritefile2 True topetriFN    iso8601 "dot"  (commentIfError "//" asPetri) asPetriErr
-    when (SFL4.tots      opts) $ mywritefile  True totsFN       iso8601 "ts"   asTSstr
+    when (SFL4.tots      opts) $ mywritefile2 True totsFN       iso8601 "ts"   (show asTSpretty) asTSerr
     when (SFL4.tonl      opts) $ mywritefile  True toNL_FN      iso8601 "txt"  asNatLang
     when (SFL4.togrounds opts) $ mywritefile  True togroundsFN  iso8601 "txt"  asGrounds
     when (SFL4.tomaude   opts) $ mywritefile  True toMaudeFN iso8601 "natural4" asMaude
@@ -337,8 +337,6 @@ main = do
 
     when (SFL4.toProlog rc) $ pPrint asProlog
 
-    when (SFL4.toTS rc) $ print $ asTypescript rules
-
     when (SFL4.only opts == "" && SFL4.workdir opts == "") $ pPrint rules
     when (SFL4.only opts == "native")  $ pPrint rules
     when (SFL4.only opts == "classes") $ pPrint (SFL4.classtable l4i)

lib/haskell/natural4/package.yaml

@@ -70,6 +70,8 @@ dependencies:
   - mono-traversable
   - string-interpolate
   - prettyprinter-interp
+  - json
+  - jsonlogic
 
 language: GHC2021
 

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE LambdaCase #-}
 
+
 {-|
 
 The Interpreter runs after the Parser. It prepares for transpilation by organizing the ruleset and providing helper functions used by multiple XPile backends.
@@ -25,8 +26,9 @@ module LS.Interpreter where
 
 import AnyAll qualified as AA
 import Control.Applicative ((<|>))
-import Control.Monad (guard)
+import Control.Monad (guard, join, forM)
 import Data.Bifunctor (first)
+import Data.Either (partitionEithers, fromRight)
 import Data.Graph.Inductive
 import Data.HashMap.Strict ((!))
 import Data.HashMap.Strict qualified as Map
@@ -36,12 +38,13 @@ import Data.List.NonEmpty as NE
 import Data.Maybe
 import Data.Text qualified as T
 import Data.Text.Lazy qualified as TL
+import Data.Traversable (for)
 import Data.Tree
 import Data.Tuple (swap)
 import Debug.Trace
-import LS.XPile.Logging (mutterd, mutterdhsf
+import LS.XPile.Logging (mutter, mutters, mutterd, mutterdhsf
                         , XPileLogE, XPileLog
-                        , pShowNoColorS, xpReturn, xpError)
+                        , pShowNoColorS, xpReturn, xpError, xpLog)
 import LS.PrettyPrinter
 import LS.RelationalPredicates
 import LS.Rule
@@ -59,10 +62,12 @@ l4interpret :: InterpreterOptions -> [Rule] -> Interpreted
 l4interpret iopts rs =
   let ct = classHierarchy rs
       st = symbolTable    iopts rs
+      (vp, vpErr) = xpLog $ attrsAsMethods rs
   in
     L4I { classtable = ct
         , scopetable = st
         , origrules  = rs
+        , valuePreds = fromRight [] vp
         }
 
 -- | Provide the fully expanded, exposed, decision roots of all rules in the ruleset,
@@ -103,6 +108,7 @@ qaHornsR l4i =
 symbolTable :: InterpreterOptions -> [Rule] -> ScopeTabs
 symbolTable _iopts rs =
   Map.fromListWith (<>) (fromGivens <> fromDefines <> fromDecides)
+  -- [BUG] this marshalling produces duplicate entries, one from where a thing is DEFINEd and one where its attributes are DECIDEd.
   -- <> trace ("all rules = " ++ TL.unpack (pShow rs)) []
   where
     fromGivens :: [(RuleName, SymTab)]
@@ -798,7 +804,87 @@ globalFacts l4i =
   , hasClauses r, Define == keyword r
   ]
 
-
-
-
-
+-- * Extract everything that looks like a method.
+--
+-- A common form is:
+-- @
+--    DECIDE ClassA's RecordAttr's AttributeName IS foo WHEN bar
+--           ClassA's RecordAttr's AttributeName IS baz WHEN quux
+--           ClassA's RecordAttr's AttributeName IS baz OTHERWISE
+-- @
+-- 
+-- Extract and return all of these decisions in the form:
+--
+-- @
+--    [([ClassA, RecordAttr, AttributeName], foo, Just bar
+-- @
+-- 
+-- | we extract the methods to a fully qualified and annotatable form defined as `ValuePredicate` -- see Types.hs
+--
+-- Go through every rule and break it down into this structure.
+
+attrsAsMethods :: RuleSet -> XPileLogE [ValuePredicate]
+attrsAsMethods rs = do
+  outs <-
+    for [ r | r@Hornlike{keyword=Decide} <- rs ] $ \r -> do
+    for (clauses r) $ \hc -> do
+      gone1 <- go hc
+      case gone1 of
+        Left errs1 -> xpError errs1
+        Right (headLHS, attrVal, attrCond) -> do
+          gone2 <- toObjectPath headLHS
+          mutterd 3 $ show headLHS <> " ... got back gone2: " <> show gone2
+          case gone2 of
+            Left errs2 -> xpError errs2
+            Right (objPath, attrName) -> do
+              let toreturn = defaultValuePredicate
+                    { origHC = Just hc
+                    , origBSR = hBody hc
+                    , objPath
+                    , attrName
+                    , attrVal
+                    , attrCond
+                    }
+              mutterd 3 $ show headLHS <> " returning"
+              mutter $ show $ srchs toreturn
+              xpReturn toreturn
+
+  let (errs, successes) = partitionEithers (concat outs)
+  mutters (concat errs)
+  xpReturn successes
+
+  where go :: HornClause2 -> XPileLogE (MultiTerm, Maybe RelationalPredicate, Maybe BoolStructR)
+        go hc@HC{..} =
+          case hHead of
+            (RPnary RPis (RPMT headLHS : headRHS : [])) -> xpReturn (headLHS, Just headRHS, hBody)
+
+            (RPnary RPis (RPMT headLHS : headRHS)) -> do
+              mutterd 3 $ "unexpected RHS in RPnary RPis: " <> show hHead
+              xpReturn (headLHS, listToMaybe headRHS, hBody)
+
+            (RPConstraint mt1 RPis mt2) -> do
+              mutterd 3 $ "converting RPConstraint in hHead: " <> show hHead
+              xpReturn (mt1, Just (RPMT mt2), hBody)
+
+            _ -> do
+              mutterd 3 "attrsAsMethods: encountered unexpected form of RelationalPredicate"
+              mutter $ show $ srchs hHead
+              xpError ["unhandled RelationalPredicate", show hHead]
+
+        -- | input: [MTT "foo's", MTT "bar's", MTT "baz"]
+        -- 
+        --  output: (["foo", "bar"], "baz")
+        toObjectPath :: MultiTerm -> XPileLogE ([EntityName], EntityName)
+        toObjectPath [] = do mutter "error: toObjectPath given an empty list!" >> xpReturn ([], "errorEntityname")
+        toObjectPath mt = do
+          mutterd 4 $ "toObjectPath input = " <> show mt
+          mutterd 4 $ "DL.init mt = " <> show (DL.init mt)
+          mutterd 4 $ "mt2text = " <> show (mt2text $ DL.init mt)
+          mutterd 4 $ "T.replace = " <> show (T.replace "'s" "'s" $ mt2text $ DL.init mt)
+          mutterd 4 $ "T.splitOn = " <> show (T.splitOn "'s" (T.replace "'s" "'s" $ mt2text $ DL.init mt))
+          mutterd 4 $ "T.strip = " <> show (T.strip <$> T.splitOn "'s" (T.replace "'s" "'s" $ mt2text $ DL.init mt))
+          mutterd 4 $ "DL.filter = " <> show (DL.filter (not . T.null) $ T.strip <$> T.splitOn "'s" (T.replace "'s" "'s" $ mt2text $ DL.init mt))
+          xpReturn (DL.filter (not . T.null) $
+                    T.strip <$> T.splitOn "'s" (T.replace "'s" "'s" $ mt2text $ DL.init mt)
+                   , mt2text [DL.last mt])
+

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

@@ -21,6 +21,7 @@ import LS.Rule
 import LS.Types
 import Prettyprinter
 import Prettyprinter.Render.Text
+import Text.Pretty.Simple ( pShowNoColor )
 
 -- | Pretty MTExpr
 instance Pretty MTExpr where
@@ -336,3 +337,8 @@ a </>  b = vvsep [ a, b ]
 a <//> b = vsep  [ a, b ]
 infixr 5 </>, <//>
 
+-- | print haskell source in a way Org prefers
+srchs :: (Show a) => a -> Doc ann
+srchs = orgsrc "haskell" . pretty . pShowNoColor
+orgsrc lang x = vsep [ "#+begin_src" <+> lang, x, "#+end_src" ]
+orgexample  x = vsep [ "#+begin_example", x, "#+end_example" ]

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

@@ -244,6 +244,7 @@ tok2rel = choice
     , RPgte     <$ pToken TokGTE
     , RPmap     <$ pToken FMap
     , RPelem    <$ pToken TokIn
+    , RPelem    <$ pToken Includes
     , RPnotElem <$ pToken TokNotIn
     , RPsubjectTo <$ pToken SubjectTo
     , RPTC TBefore <$ pToken Before

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

@@ -43,6 +43,7 @@ import LS.Types
     TemporalConstraint,
     TypeSig,
     WithPos (WithPos, pos, tokenVal),
+    ValuePredicate,
     bsp2text,
     dlToList,
     liftMyToken,
@@ -380,6 +381,9 @@ data Interpreted = L4I {
   -- @[Rule]@; the latter is technically redundant and can be safely
   -- eliminated. [TODO].
   , origrules  :: [Rule]
+
+  -- | valuepredicates contain the bulk of the top-level decision logic, and can be easily expressed as instance or class methosd.
+  , valuePreds :: [ValuePredicate]
   }
   deriving (Eq, Ord, Show)
 

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

@@ -384,6 +384,7 @@ instance Hashable a => Hashable (TemporalConstraint a)
 
 type RuleName   = MultiTerm
 type EntityType = Text.Text
+type EntityName = Text.Text
 
 data TypeSig = SimpleType ParamType EntityType
              | InlineEnum ParamType ParamText
@@ -414,6 +415,35 @@ getUnderlyingType   (SimpleType TList0    s1) = Right s1
 getUnderlyingType   (SimpleType TList1    s1) = Right s1
 getUnderlyingType   (InlineEnum _pt1      __) = Left "type declaration cannot inherit from _enum_ superclass"
 
+-- | when the input says @DECIDE ClassA's RecordAttr's AttributeNAME IS foo WHEN bar@
+-- we rewrite that to a `ValuePredicate`.
+data ValuePredicate = ValPred
+  { moduleName :: [EntityName]  -- MoneyLib
+  , scopeName  :: [EntityName]  -- DollarJurisdictions
+  , objPath    :: [EntityName]  -- ClassA, RecordAttr. If this list is null, then the "attribute" is toplevel / module-global
+  , attrName   ::  EntityName   -- AttributeName
+  , attrRel    ::  Maybe RPRel
+  , attrVal    ::  Maybe RelationalPredicate
+  , attrCond   ::  Maybe BoolStructR
+  , attrIType  ::  Inferrable TypeSig
+  , origBSR    ::  Maybe BoolStructR
+  , origHC     ::  Maybe HornClause2
+  }
+  deriving (Show, Eq, Ord, Generic)
+
+defaultValuePredicate = ValPred
+  { moduleName = []
+  , scopeName  = []
+  , objPath    = []
+  , attrName   = "defaultAttrName"
+  , attrRel    = Just   RPis
+  , attrVal    = Just $ RPMT [MTT "defaultAttrVal"]
+  , attrCond   = Nothing
+  , attrIType  = defaultInferrableTypeSig
+  , origBSR    = Nothing
+  , origHC     = Nothing
+  }
+
 -- * what's the difference between SymTab, ClsTab, and ScopeTabs?
 
 -- | ClsTab: things that are explicitly defined in a Type Declaration (DECLARE ... HAS ...) end up in the ClsTab
@@ -455,6 +485,8 @@ type SymTab = Map.HashMap MultiTerm (Inferrable TypeSig, [HornClause2])
 --   If type checking / inference have not been implemented the snd will be empty.
 type Inferrable ts = (Maybe ts, [ts])
 
+defaultInferrableTypeSig = (Nothing, [])
+
 thisAttributes, extendedAttributes :: ClsTab -> EntityType -> Maybe ClsTab
 
 -- | attributes defined in the type declaration for this class specifically

lib/haskell/natural4/src/LS/XPile/Org.hs

@@ -21,6 +21,7 @@ import LS.Interpreter
       classGraph,
       extractEnums,
       defaultToSuperClass, defaultToSuperType,
+      attrsAsMethods,
       )
 
 import LS.RelationalPredicates ( partitionExistentials, getBSR )
@@ -37,19 +38,18 @@ import LS.Types ( unCT
                 , ClassHierarchyMap
                 )
 import LS.PrettyPrinter
-    ( myrender, vvsep, (</>), tildes, (<//>), snake_case )
+    ( myrender, vvsep, (</>), tildes, (<//>), snake_case, srchs, orgexample )
 
 import Prettyprinter
     ( vsep, viaShow, hsep, emptyDoc, (<+>), Pretty(pretty), Doc, indent, line )
-import Text.Pretty.Simple ( pShowNoColor )
 import Data.HashMap.Strict qualified as Map
 import Data.Maybe (mapMaybe)
 import Data.List (nub)
 import qualified Data.List.NonEmpty as NE
 import Data.Bifunctor (first)
 import Data.Graph.Inductive (prettify)
 import Data.Text qualified as Text
-
+import LS.XPile.Logging
 
 -- | org-mode output
 toOrg :: Interpreted -> [Rule] -> String
@@ -113,8 +113,12 @@ musings l4i rs =
                            | (mt, (its, hc)) <- Map.toList st ]
                    | (rn, st) <- Map.toList $ scopetable l4i ]
 
+           , "** attributes as methods"
+           , "we dump expressions of the form DECIDE class's record's attribute IS someValue WHEN someCondition"
+           , let aam = xpLog $ attrsAsMethods rs -- [TODO] this duplicates work done in the Interpreter -- find a way to coherently log common errors from the Interpreter itself, clean up l4i's valuePreds
+             in srchs (fst aam) </> vsep (pretty <$> snd aam)
            , "** the Rule Decision Graph"
-           , example (pretty (prettify (first ruleLabelName decisionGraph)))
+           , orgexample (pretty (prettify (first ruleLabelName decisionGraph)))
 
            , "** Decision Roots"
            , "rules which are not just RuleAlises, and which are not relied on by any other rule"
@@ -193,9 +197,3 @@ musings l4i rs =
                    </> "**** local variables" </> srchs (ruleLocals l4i r)
                    | r <- rs ]
            ]
-  where
-    srchs :: (Show a) => a -> Doc ann
-    srchs = src "haskell" . pretty . pShowNoColor
-    src lang x = vsep [ "#+begin_src" <+> lang, x, "#+end_src" ]
-    example  x = vsep [ "#+begin_example", x, "#+end_example" ]
-