Let-bind GroupValueExpr; add type-check + parser + tests

Test: "parse (prettyPrint absyn) == absyn".
An infinite loop seems to occur at depth >= 3.
Is this a faulty 'Serial' instance in "test/Orphans.hs"?

app/Main.hs

@@ -1,72 +1,89 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveGeneric #-}
 module Main where
 
 import LangPrelude
-import qualified Output
-import qualified Sunburst.D3
-import qualified Eval.RuleExpr
-import qualified Eval.DataExpr
-import qualified Eval.Types
-import qualified Tree                             as Tree
-import qualified Rules.CountryBondValue
-import qualified Rules.FiveTenForty
-import           System.Environment               (getArgs)
-import           System.IO                        (stderr, hPutStrLn)
-import qualified Data.Text                        as T
-import qualified Data.Aeson                       as Json
-import qualified Data.ByteString.Lazy.Char8       as Char8
-import qualified Data.List.NonEmpty               as NE
+import qualified Parse
+import qualified Text.Show.Pretty
+import qualified Text.Megaparsec
+import qualified Data.Text as T
 
 
-main :: IO ()
-main = do
-    inputFile <- argOrFail <$> getArgs
-    positions <- toNonEmpty . value . handleDecodeResult <$> Json.eitherDecodeFileStrict' inputFile
-    evalRule "CountryBondValue" positions Rules.CountryBondValue.ruleExpr
-    evalRule "FiveTenForty" positions Rules.FiveTenForty.ruleExpr
-  where
-    evalRule name positions rule = do
-        hPutStrLn stderr $ "Rule: " <> name
-        let (rulePassed, langErrors) = handleEvalResult $
-                Eval.RuleExpr.runEvalRule positions rule
-        hPutStrLn stderr $ "Passed: " ++ show rulePassed
-        hPutStrLn stderr $ "Errors:"
-        mapM_ (hPutStrLn stderr . ("\t" ++)) (map showResult langErrors)
-        hPutStrLn stderr $ "\n"
-    securityIdTree :: Tree.Tree [Eval.Types.Position] -> Tree.Tree [Text]
-    securityIdTree = fmap (map (showValue . Output.getSecurityIdOrFail))
-    toNonEmpty = fromMaybe (error "ERROR: Empty input data") . NE.nonEmpty
-    printJson = Char8.putStrLn . Json.encode . Output.toObjectSecId . NE.fromList
-    handleDecodeResult (Left e) = error $ "ERROR: JSON decoding error: \n" ++ e
-    handleDecodeResult (Right r) = r
-    argOrFail [inputFile] = inputFile
-    argOrFail _ = error "ERROR: provide JSON input file name as argument"
+parse :: Text -> IO ()
+parse input =
+    case Text.Megaparsec.parse Parse.documentParser "" input of
+        Left  e -> putStr (Text.Megaparsec.errorBundlePretty e)
+        Right x -> Text.Show.Pretty.pPrint x
 
-handleEvalResult (Left e) = error $ "An error occurred evaluating the rule:\n" ++ T.unpack e
-handleEvalResult (Right r) = r
+main = parse test999
 
-showResult (Eval.DataExpr.Result posList _ status) =
-    unwords [ toS $ T.concat . NE.toList $ NE.map (showValue . Output.getSecurityIdOrFail) posList
-            , ":"
-            , show status
-            ]
 
-sunburstTree positions = do
-    hPutStrLn stderr $ "DataExpr:"
-    let (tree, dataErrors) = handleEvalResult $
-            Eval.DataExpr.runEvalData positions Rules.CountryBondValue.countryIssuers
-    Char8.putStrLn . Json.encode $
-        Sunburst.D3.convert (fromMaybe 100000 . fmap jsonDouble . LangPrelude.lookup "DirtyValue") tree
-    -- hPutStrLn stderr $ Tree.drawTree $ securityIdTree tree
-    hPutStrLn stderr $ "\nDataExpr errors:"
-    mapM_ (hPutStrLn stderr) (map showResult dataErrors)
-  where
-    jsonDouble (Json.Number a) = realToFrac a
-    jsonDouble a = error $ "BUG: " ++ show a
+mainTest = test999
 
-data JsonData = JsonData
-    { value   :: [Eval.Types.Position]
-    } deriving Generic
+test999 = T.unlines
+    [ "let homeCountry = \"DK\""
+    , "let foreignCountries = portfolio grouped by Country where Country != homeCountry"
+    , "for each country in foreignCountries {"
+    , "    let relativeCountryValue = sum Value of country relative to Portfolio"
+    , "    let numCountrySecurities = count (country grouped by SecurityId)"
+    , "    if relativeCountryValue > 60% {"
+    , "        numCountrySecurities >= 20"
+    , "        for each SecurityID:"
+    , "            sum Value of SecurityID relative to Country <= 5%"
+    , "    } else if relativeCountryValue > 40% {"
+    , "        numCountrySecurities >= 10"
+    , "    }"
+    , "}"
+    ]
+
+test22 :: Text
+test22 =
+    T.unlines
+        [ "let countryCount = count (portfolio grouped by Country)"
+        , "for each Country in portfolio              "
+        , "{"
+        , "   for each Issuer in Country {              "
+        , "      rule: average Exposure of Issuer < 3   "
+        , "      rule: sum Exposure of Issuer relative to Country <= 5%"
+        , "   }                                         "
+        , "}                                            "
+        , "rule: sum DirtyValue of Country >= 100000    "
+        ]
+
+test0 :: Text
+test0 =
+    T.unlines
+        [ "rule: sum DirtyValue of Country >= 100000"
+        , "rule: sum DirtyValue of Country >= 100000"
+        ]
+
+test1 :: Text
+test1 =
+    T.unlines
+        [ "for each Country in portfolio {"
+        , "   rule: sum DirtyValue of Country >= 100000"
+        , "}"
+        , "rule: average Exposure of portfolio < 3"
+        ]
+
+test2 :: Text
+test2 =
+    T.unlines
+        [ "for each Country in (portfolio grouped by Country where sum DirtyValue of Country >= 10000):"
+        , "   rule: sum DirtyValue of Country >= 100000"
+        ]
+
+test3 :: Text
+test3 =
+    T.unlines
+        [ "let portfolioValue = sum DirtyValue of portfolio"
+        , "for each Country in portfolio:"
+        , "   rule: sum DirtyValue of Country <= 90000000"
+        ]
+
+test4 :: Text
+test4 =
+    T.unlines
+        [ "let portfolioValue = sum DirtyValue of portfolio"
+        , "for each Country in portfolio:"
+        , "   rule: sum DirtyValue of Country relative to portfolioValue <= 10%"
+        ]
 
-instance Json.FromJSON JsonData

package.yaml

@@ -31,6 +31,7 @@ library:
     - protolude
     - containers
     - megaparsec
+    - parsers
 
 executables:
   rule-lang-exe:
@@ -43,3 +44,23 @@ executables:
       - aeson
       - unordered-containers  # Output
       - hashable              # Output
+      - pretty-show
+      - megaparsec
+
+tests:
+  rule-lang-test:
+    main:                Spec.hs
+    source-dirs:         test
+    dependencies:
+      - rule-lang
+      - megaparsec
+      - smallcheck
+      - tasty
+      - tasty-smallcheck
+      - text
+      # HSpec
+      - hspec
+      - hspec-smallcheck
+      - hspec-expectations-pretty-diff
+    ghc-options:
+      - -O2