Remove redundant code

lib/haskell/natural4/app/Main.hs

@@ -822,7 +822,7 @@ aajsonTranspiler =
   where
     go = withNLGData (\ nlgd ds -> do
       let (psResult, psErrors) = xpLog do
-            translate2AaJson nlgd.allEnv nlgd.env ds.interpreted
+            translate2AaJson nlgd.allEnv ds.interpreted
       pure (Success (commentIfError "-- ! -- " psResult) (Just psErrors))
       )
 

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -Wall #-}
 
 -- [TODO] export list
 
@@ -69,15 +70,6 @@ import Data.Aeson.Encode.Pretty (encodePretty)
 -- far future: construct a JSON with everything in it, and get the Purescript to read the JSON, so we are more interoperable with non-FP languages
 
 
--- | shim for Purescript tuples which use slightly different syntax
-data Tuple a b = Tuple a b
-  deriving (Show, Eq, Ord)
-
--- | output Haskell tuples to Purescript
-toTuple :: (a,b) -> Tuple a b
-toTuple (x,y) = Tuple x y
-
-
 labelToAaJson :: AA.Label T.Text -> Value
 labelToAaJson (AA.Pre a) = object [ "Pre" .= a ]
 labelToAaJson (AA.PrePost a b) = object [ "PrePost" .= [a,b] ]
@@ -89,122 +81,27 @@ bsToAaJson (AA.Any l bs) = object [ "Any" .= object["label" .= labelToAaJson l,
 bsToAaJson (AA.Leaf a) = object [ "Leaf" .= a ]
 bsToAaJson (AA.Not bs) = object [ "Not" .= bsToAaJson bs]
 
-instance ToJSON (Tuple String BoolStructLT) where
- toJSON (Tuple a b) =
-    object [ fromString a .= bsToAaJson b]
-
--- | RuleName to text multiterm
-textMT :: [RuleName] -> [T.Text]
-textMT = map mt2text
+toAaJson :: (String, BoolStructLT) -> Value
+toAaJson (a, b) = object [ fromString a .= bsToAaJson b]
 
 slashNames :: [RuleName] -> String
 slashNames names = T.unpack (T.intercalate " / " (mt2text <$> names))
 
--- two boolstructT: one question and one phrase
-namesAndStruct :: Interpreted -> [Rule] -> XPileLog [([RuleName], [BoolStructT])]
-namesAndStruct l4i rl = do
-  pure [ (names, [bs]) | (names, bs) <- qaHornsT l4i]
-
--- | for each rule, construct the questions for that rule;
--- and then jam them together with all the names for all the rules???
-namesAndQ :: NLGEnv -> Interpreted -> [Rule] -> XPileLog [([RuleName], [BoolStructT])]
-namesAndQ env l4i rl = do
-  expandedRules <- expandRulesForNLGE l4i rl
-  questStruct <- traverse (ruleQuestions env alias) expandedRules
-  let wut = concat [ [ (name, q) -- [TODO] this is probably the source of bugs.
-                     | q' <- q ]
-                   | q <- questStruct ]
-  return wut
-  where
-    name = map ruleLabelName rl
-    alias = listToMaybe [ (you,org) | DefNameAlias you org _ _ <- rl]
-
--- | not sure why this is throwing away information
-combine :: [([RuleName], [BoolStructT])]
-        -> [([RuleName], [BoolStructT])]
-        -> XPileLog [([RuleName], [BoolStructT])]
-combine = combine' 3
-
-combine' :: Int -- ^ depth
-         -> [([RuleName], [BoolStructT])]
-         -> [([RuleName], [BoolStructT])]
-         -> XPileLog [([RuleName], [BoolStructT])]
-
-combine' d [] []     = pure []
-combine' d (b:bs) [] = pure []
-combine' d [] (q:qs) = pure []
-combine' d (b:bs) (q:qs) = do
-  (:) (fst b, snd b <> snd q) <$> combine' (d+1) bs qs
-
-
--- [TODO] shouldn't this recurse down into the All and Any structures?
--- something like fixNot AA.Any k xs = AA.Any k (fixNot <$> xs)
-fixNot :: BoolStructT -> BoolStructT
-fixNot (AA.Leaf x) = AA.Leaf x
-fixNot (AA.Not (AA.Leaf x)) = AA.Leaf x
-fixNot y = y
-
--- | this throws away the first argument, in favour of the second. Not sure about this ...
-justQuestions :: BoolStructT -> [BoolStructT] -> BoolStructT
-justQuestions (AA.All Nothing a) q = AA.All Nothing q
-justQuestions (AA.Any Nothing a) q = AA.Any Nothing q
-justQuestions xs y = xs
-
-justStatements :: BoolStructT -> [BoolStructT] -> BoolStructT
-justStatements (AA.All Nothing a) q = AA.All Nothing a
-justStatements (AA.Any Nothing a) q = AA.Any Nothing a
-justStatements xs y = xs
-
-labelQs :: [AA.OptionallyLabeledBoolStruct T.Text] -> [AA.BoolStruct (AA.Label T.Text) T.Text]
-labelQs = map alwaysLabeled
-
-biggestQ :: NLGEnv -> Interpreted -> [Rule] -> XPileLog [BoolStructT]
-biggestQ env l4i rl = do
-  let alias = listToMaybe [ (you,org) | DefNameAlias{name = you, detail = org} <- rl]
-  q <- ruleQuestionsNamed env alias `traverse` expandRulesForNLG l4i  rl
-  let flattened = q |$> second (AA.extractLeaves <$>)
-      onlyqs = Map.fromList q
-      sorted = sortOn (Data.Ord.Down . DL.length) flattened
-  case (null sorted, fst (DL.head sorted) `Map.lookup` onlyqs) of
-    (True, _) -> pure []
-    (_, Nothing) -> do
-      pure []
-    (_, Just x) -> pure x
-
-biggestS :: NLGEnv -> Interpreted -> [Rule] -> XPileLog [BoolStructT]
-biggestS env l4i rl = do
-  q <- join $ combine <$> namesAndStruct l4i rl <*> namesAndQ env l4i rl
-  let flattened = q |$> second (AA.extractLeaves <$>)
-
-      onlys = Map.fromList
-        [ (x, justStatements yh (map fixNot yt))
-        | (x,y) <- q
-        , let Just (yh, yt) = DL.uncons y ]
-
-      sorted = sortOn (Data.Ord.Down . DL.length) flattened
-  return $
-    if null sorted
-      then []
-      else pure $ onlys ! fst (DL.head sorted)
-
-translate2AaJson :: [NLGEnv] -> NLGEnv -> Interpreted -> XPileLogE String
-translate2AaJson nlgEnvs eng l4i = do
-  let rules = origrules l4i
 
-  bigQ <- biggestQ eng l4i rules
+translate2AaJson :: [NLGEnv] -> Interpreted -> XPileLogE String
+translate2AaJson nlgEnvs l4i = do
+  let rules = origrules l4i
 
   qaHornsAllLangs :: [Either XPileLogW String] <-
-    for nlgEnvs \nlgEnv@(NLGEnv {gfLang}) -> do
-      let nlgEnvStrLower = gfLang |> showLanguage |$> Char.toLower
-          listOfMarkings = l4i |> getMarkings |> AA.getMarking |> Map.toList
+    for nlgEnvs \nlgEnv -> do
 
-      hornByLang :: Either XPileLogW [Tuple String (AA.BoolStruct (AA.Label T.Text) T.Text)] <-
+      hornByLang :: Either XPileLogW [(String, BoolStructLT)] <-
         qaHornsByLang rules nlgEnv l4i
 
       case hornByLang of
         Left err -> xpError err
-        Right hornByLang -> xpReturn [__i|
-            #{encodePretty $ toJSON $ DL.nub hornByLang}
+        Right haveHorn -> xpReturn [__i|
+            #{encodePretty $ toAaJson <$> (DL.nub haveHorn)}
         |]
 
   let qaHornsStrings = rights qaHornsAllLangs
@@ -214,14 +111,12 @@ translate2AaJson nlgEnvs eng l4i = do
     ]
   |]
 
-
-qaHornsByLang :: [Rule] -> NLGEnv -> Interpreted -> XPileLogE [Tuple String (AA.BoolStruct (AA.Label T.Text) T.Text)]
+qaHornsByLang :: [Rule] -> NLGEnv -> Interpreted -> XPileLogE [(String, BoolStructLT)]
 qaHornsByLang rules langEnv l4i = do
   let alias = listToMaybe [ (you,org) | DefNameAlias{name = you, detail = org} <- rules]
       subject = listToMaybe [ parseSubj langEnv person | Regulative{subj = person} <- rules]
       qaHT = textViaQaHorns langEnv l4i subject
       qaHornNames = foldMap fst qaHT
-      d = 4
   allRQs <- ruleQuestionsNamed langEnv alias `traverse` expandRulesForNLG l4i rules
 
   measuredRQs <- for allRQs \(rn, asqn) -> do
@@ -246,9 +141,5 @@ qaHornsByLang rules langEnv l4i = do
 
   let qaHTBit = qaHornsWithQuestions
                   |$> bimap slashNames alwaysLabeled
-                  |$> toTuple
 
   xpReturn qaHTBit
-
-interviewRulesRHS2topBit :: TL.Text -> String
-interviewRulesRHS2topBit interviewRulesRHS = ""

lib/haskell/natural4/test/LS/XPile/AaJsonSpec.hs

@@ -77,7 +77,7 @@ transpileFile filename = do
         nlgEnvs = justNLGDate.allEnv
         eng = justNLGDate.env
         (psResult, _) = xpLog do
-            translate2AaJson nlgEnvs eng l4i
+            translate2AaJson nlgEnvs l4i
 
     case psResult of
         Left err -> do