Add renamer phase and a simala backend for natural4

lib/haskell/cabal.project

@@ -27,6 +27,11 @@ source-repository-package
   location: https://github.com/anka-213/haskell-wordnet
   tag: a6d675bcbe1585fc652f95f60e0dec826a660646
 
+source-repository-package
+  type: git
+  location: https://github.com/smucclaw/simala
+  tag: 85afeb86678a65d48bfac2bbb90306693d51582e
+
 allow-newer:
   compact:*,
   udpipe-hs:base,

lib/haskell/natural4/app/Main.hs

@@ -83,6 +83,7 @@ import LS.XPile.Petri (toPetri)
 import LS.XPile.Prolog (rulesToProlog, rulesToSCasp)
 import LS.XPile.Purescript (translate2PS)
 import LS.XPile.SVG qualified as AAS
+import LS.XPile.Simala.Transpile qualified as Simala
 import LS.XPile.Typescript (asTypescript)
 import LS.XPile.Uppaal qualified as Uppaal
 import LS.XPile.VueJSON
@@ -123,6 +124,8 @@ import System.IO.Unsafe (unsafeInterleaveIO)
 import Text.Pretty.Simple (pPrint, pShowNoColor)
 import Text.Regex.PCRE.Heavy qualified as PCRE
 import Text.XML.HXT.Core qualified as HXT
+import qualified LS.Renamer as Renamer
+import LS.Renamer.Rules (RnRule)
 
 --
 -- Command-line options parsing
@@ -275,7 +278,7 @@ main = do
   rc       <- SFL4.getConfig opts
 --  putStrLn "main: doing dumpRules"
   rules    <- SFL4.dumpRules opts
-  let l4i  = l4interpret rules
+  l4i      <- l4interpret rules
   iso8601  <- now8601
 
   -- NLG stuff
@@ -550,6 +553,10 @@ transpilersMap =
     , "an anyall SVG of the decision trees"
     , [aasvgTranspiler]
     )
+  , ( SFL4.simalaMode
+    , "Transpile hornlike rules to the purely functional Simala language"
+    , [simalaTranspiler]
+    )
   ]
 
 toNative :: [SFL4.Rule] -> SFL4.Interpreted -> String
@@ -652,6 +659,13 @@ withNLGData k ds =
     Nothing  -> pure (Skipped "skipping transpiler due to lacking NLG environment")
     Just env -> k env ds
 
+withRnRules :: ([RnRule] -> (TranspilationResult a)) -> DriverState -> (TranspilationResult a)
+withRnRules k ds = case ds.interpreted.renamedRules of
+  Renamer.RenamerFail errMsg _scope -> Skipped $ "Failed to rename rules: " <> errorToString errMsg
+  Renamer.RenamerSuccess rnRules _scope -> k rnRules
+  where
+    errorToString = Text.unpack . Renamer.renderRenamerError
+
 simpleTranspiler ::
      FilePath
   -> String
@@ -1109,6 +1123,14 @@ aasvgTranspiler =
           Nothing ->
             pure () -- no on-screen output
 
+simalaTranspiler :: Transpiler
+simalaTranspiler =
+  simpleTranspiler "simala" "simala" (withRnRules runSimalaTranspiler)
+  where
+    runSimalaTranspiler rnRules = case Simala.runSimalaTranspiler rnRules of
+      Left err -> mkResultWithErrors ("", lines $ Text.unpack $ Simala.renderTranspilerError err)
+      Right decls -> mkResultWithoutErrors (Text.unpack $ Simala.render decls)
+
 rulesTranspiler :: Transpiler
 rulesTranspiler =
   screenTranspiler "rules" (withoutErrors (onlyRules id))

lib/haskell/natural4/package.yaml

@@ -25,6 +25,7 @@ description: natural4 parses a Legal Spreadsheet's CSV and transpiles to multipl
 dependencies:
   - base >= 4.7 && < 5
   - containers
+  - co-log-core
   - unordered-containers
   - hashable
   - flow
@@ -95,6 +96,8 @@ dependencies:
   # - holmes
 # Note: when adding `extra-deps` in `stack.yaml`, have to add them under the relevant package in `package.yaml` too
 # See https://docs.haskellstack.org/en/stable/stack_yaml_vs_cabal_package_file/#why-specify-dependencies-twice
+  # Dependencies specific to the WIP simala backend
+  - simala
 
 language: GHC2021
 

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

@@ -112,6 +112,9 @@ import LS.RelationalPredicates
     getBSR,
     partitionExistentials,
   )
+import LS.Renamer.Rules (RnRule)
+import qualified LS.Renamer as Renamer
+import qualified LS.Renamer.Scope as Scope
 import LS.Rule
   ( Rule
       ( DefTypically,
@@ -216,7 +219,6 @@ import LS.XPile.Logging
 import Text.Pretty.Simple (pShowNoColor)
 import Text.Regex.PCRE.Heavy qualified as PCRE
 
-
 -- | This is generated by the Interpreter and handed around to different transpilers.
 --
 -- In the future we may add to this list of attributes the following frequently called functions:
@@ -242,6 +244,8 @@ data Interpreted = L4I {
   -- eliminated. [TODO].
   , origrules  :: [Rule]
 
+  , renamedRules :: Renamer.RenamerResult [RnRule]
+
   -- | valuepredicates contain the bulk of the top-level decision logic, and can be easily expressed as instance or class methosd.
   , valuePreds :: [ValuePredicate]
 
@@ -257,6 +261,7 @@ defaultL4I = L4I
   { classtable = CT Map.empty
   , scopetable = Map.empty
   , origrules = mempty
+  , renamedRules = Renamer.RenamerSuccess mempty Scope.emptyScope
   , valuePreds = mempty
   , ruleGraph = Gr.empty
   , ruleGraphErr = mempty
@@ -280,22 +285,24 @@ type RuleGraph = Gr Rule RuleGraphEdgeLabel
 -- handed to each transpiler for use, as an `l4i` argument.
 --
 
-l4interpret :: [Rule] -> Interpreted
-l4interpret rs =
+l4interpret :: [Rule] -> IO Interpreted
+l4interpret rs = do
   let ct :: ClsTab
       ct = classHierarchy rs
       st :: ScopeTabs
       st = symbolTable rs
       (vp, _vpErr) = xpLog $ attrsAsMethods rs
       (rDGout, rDGerr) = xpLog $ ruleDecisionGraph rs
-  in
-    L4I { classtable = ct
-        , scopetable = st
-        , origrules  = rs
-        , valuePreds = fromRight [] vp
-        , ruleGraph  = rDGout
-        , ruleGraphErr = rDGerr
-        }
+  rnRules <- Renamer.runRenamerFor mempty rs
+
+  pure L4I { classtable = ct
+           , scopetable = st
+           , origrules  = rs
+           , renamedRules = rnRules
+           , valuePreds = fromRight [] vp
+           , ruleGraph  = rDGout
+           , ruleGraphErr = rDGerr
+           }
 
 -- | Provide the fully expanded, exposed, decision roots of all rules in the ruleset,
 --   grouped ("nubbed") into rule groups (since multiple rules may have the same decision body).
@@ -1151,7 +1158,7 @@ globalFacts l4i = do
           pure $ Node pt []
       }
 
--- * Extract everything that looks like a method.
+-- | Extract everything that looks like a method.
 --
 -- A common form is:
 -- @
@@ -1166,7 +1173,7 @@ globalFacts l4i = do
 --    [([ClassA, RecordAttr, AttributeName], foo, Just bar
 -- @
 --
--- | we extract the methods to a fully qualified and annotatable form defined as `ValuePredicate` -- see Types.hs
+-- 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.
 

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

@@ -65,6 +65,7 @@ module LS.Lib
     vueMode,
     pursMode,
     uppaalMode,
+    simalaMode,
     defaultModes,
     knownModes
   )
@@ -419,6 +420,7 @@ defaultModes =
   , mathlangmwMode
   , genmathlangMode
   , introMode
+  , simalaMode
   ]
 
 -- | All known modes, including ones that are off by default.
@@ -547,6 +549,9 @@ genmathlangMode = MkModeName "genmathlang"
 introMode :: ModeName
 introMode = MkModeName "intro"
 
+simalaMode :: ModeName
+simalaMode = MkModeName "simala"
+
 getConfig :: Options -> IO RunConfig
 getConfig o = do
   mpd <- lookupEnv "MP_DEBUG"

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

@@ -0,0 +1,43 @@
+module LS.Log (
+  -- * Logger Type and utility functions
+  Tracer (..),
+  traceWith,
+  cmap,
+  module CoFunctor,
+
+  -- * Experimental logger backends
+  prettyTracer,
+)
+where
+
+import Data.Functor.Contravariant as CoFunctor
+import Prettyprinter
+import Prettyprinter.Render.Text (renderStrict)
+import System.IO (stderr)
+import qualified Data.Text.IO as Text
+
+newtype Tracer m a = Tracer {runTracer :: a -> m ()}
+
+instance Contravariant (Tracer m) where
+  contramap f (Tracer m) = Tracer (m . f)
+
+instance (Applicative m) => Semigroup (Tracer m a) where
+  tracer1 <> tracer2 = Tracer $ \a -> runTracer tracer1 a *> runTracer tracer2 a
+
+instance (Applicative m) => Monoid (Tracer m a) where
+  mempty = Tracer $ \_ -> pure ()
+
+traceWith :: Tracer m a -> a -> m ()
+traceWith tracer msg = runTracer tracer msg
+
+-- | Shorter name for 'contramap' specialised to
+cmap :: forall a' a m. (a' -> a) -> Tracer m a -> Tracer m a'
+cmap = contramap
+
+prettyTracer :: (Pretty a) => Tracer IO a
+prettyTracer =
+  Tracer $
+    Text.hPutStrLn stderr
+      . renderStrict
+      . layoutPretty defaultLayoutOptions
+      . pretty