diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,10 +6,44 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). -## Unreleased +## v0.3.0 — 2024-03-26 -## 0.2.0 — 2024-02-16 +In this version the main executable has been renamed to `normalizer` +and several commands have been implemented for normalization, dataization, +and reporting. +New: + +- Command Line Interface: + - Add commands: + - `normalizer transform` to perform normalization without executing any atoms (was default behavior before) + - `normalizer metrics` to compute metrics of a given φ-expression (see [#153](https://github.com/objectionary/normalizer/pull/153)) + - `normalizer dataize` to run partial evaluation of φ-expressions with atoms (see [#187](https://github.com/objectionary/normalizer/pull/187)) + - `normalizer report` to generate report based on the results of testing against the EO compiler (see [#213](https://github.com/objectionary/normalizer/pull/213)) + - Add `--single` flag (see [#131](https://github.com/objectionary/normalizer/pull/131)) + - Add `--json` flag for machine-readable output format (see [#143](https://github.com/objectionary/normalizer/pull/143)) + - Add `--max-depth=N` and `--max-term-size=N` options to control limits for the normalizer (see [#173](https://github.com/objectionary/normalizer/pull/173)) + - Improve `--chain` option to provide better elaboration on the applied normalization rules and the dataization process (see [#195](https://github.com/objectionary/normalizer/pull/195)) +- Update rule set for φ-calculus (see [#152](https://github.com/objectionary/normalizer/pull/152) and some changes in [#136](https://github.com/objectionary/normalizer/pull/136) and [#166](https://github.com/objectionary/normalizer/pull/166)) +- Add property-based and regression tests for confluence (see [#136](https://github.com/objectionary/normalizer/pull/136) and [#166](https://github.com/objectionary/normalizer/pull/166)) +- Tests and metrics against the EO compiler and standard EO test suite (see [#98](https://github.com/objectionary/normalizer/pull/98), [#191](https://github.com/objectionary/normalizer/pull/191)) + +Fixes: + +- Count metrics, including dataless objects, correctly (see [#142](https://github.com/objectionary/normalizer/pull/142), [#193](https://github.com/objectionary/normalizer/pull/193), [#211](https://github.com/objectionary/normalizer/pull/211)) +- Fix metavariables in context patterns (see [#174](https://github.com/objectionary/normalizer/pull/174)) +- Support empty Δ-bindings (see [#184](https://github.com/objectionary/normalizer/pull/184)) + +Documentation has been improved (see [#134](https://github.com/objectionary/normalizer/pull/134), [#221](https://github.com/objectionary/normalizer/pull/221)). + +Maintenance: + +- Run CI on all pull requests (see [#156](https://github.com/objectionary/normalizer/pull/156)) +- Downgrade Stackage snapshot (see [#146](https://github.com/objectionary/normalizer/pull/146)) +- Add HLint to CI (see [#157](https://github.com/objectionary/normalizer/pull/157)) + +## v0.2.0 — 2024-02-16 + - Complete implementation of Yegor's rules (see [#109](https://github.com/objectionary/normalizer/pull/109), [#112](https://github.com/objectionary/normalizer/pull/112)) - Support global counter in user-defined rules (see [#105](https://github.com/objectionary/normalizer/pull/105)) - Context matching (global object and this object, see [#99](https://github.com/objectionary/normalizer/pull/99)) @@ -22,6 +56,6 @@ - Remove logs from default output (see [#106](https://github.com/objectionary/normalizer/pull/106)) - Allow collection of metrics for $\varphi$-terms (see [#121](https://github.com/objectionary/normalizer/pull/121)) -## 0.1.0 - 2024-02-02 +## v0.1.0 - 2024-02-02 First version of the normalizer. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,80 +1,458 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-partial-fields #-} {-# OPTIONS_GHC -Wno-type-defaults #-} -module Main where +module Main (main) where -import Control.Monad (unless, when) +import Control.Monad (forM, unless, when) import Data.Foldable (forM_) -import Data.List (nub) -import Language.EO.Phi (Object (Formation), Program (Program), defaultMain, parseProgram, printTree) -import Language.EO.Phi.Rules.Common (Context (..), applyRules, applyRulesChain) -import Language.EO.Phi.Rules.Yaml (RuleSet (rules, title), convertRule, parseRuleSetFromFile) -import Options.Generic -import System.IO (IOMode (WriteMode), hClose, hPutStr, hPutStrLn, openFile, stdout) +import Control.Exception (Exception (..), SomeException, catch, throw) +import Data.Aeson (ToJSON) +import Data.Aeson.Encode.Pretty (Config (..), Indent (..), defConfig, encodePrettyToTextBuilder') +import Data.List (intercalate) +import Data.String.Interpolate (i, iii) +import Data.Text.Internal.Builder (toLazyText) +import Data.Text.Lazy as TL (unpack) +import Data.Yaml (decodeFileThrow) +import GHC.Generics (Generic) +import Language.EO.Phi (Bytes (Bytes), Object (Formation), Program (Program), parseProgram, printTree) +import Language.EO.Phi.Dataize (dataizeRecursively, dataizeRecursivelyChain, dataizeStep, dataizeStepChain) +import Language.EO.Phi.Metrics.Collect as Metrics (getProgramMetrics) +import Language.EO.Phi.Metrics.Data as Metrics (ProgramMetrics (..), splitPath) +import Language.EO.Phi.Report.Data (Report'InputConfig (..), Report'OutputConfig (..), ReportConfig (..), ReportItem (..), makeProgramReport, makeReport) +import Language.EO.Phi.Report.Html (ReportFormat (..), reportCSS, reportJS, toStringReport) +import Language.EO.Phi.Report.Html qualified as ReportHtml (ReportConfig (..)) +import Language.EO.Phi.Rules.Common (ApplicationLimits (ApplicationLimits), applyRulesChainWith, applyRulesWith, defaultContext, objectSize, propagateName1) +import Language.EO.Phi.Rules.Yaml (RuleSet (rules, title), convertRuleNamed, parseRuleSetFromFile) +import Options.Applicative hiding (metavar) +import Options.Applicative qualified as Optparse (metavar) +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.FilePath (takeDirectory) +import System.IO (IOMode (WriteMode), getContents', hFlush, hPutStr, hPutStrLn, openFile, stdout) -data CLINamedParams = CLINamedParams +data CLI'TransformPhi = CLI'TransformPhi { chain :: Bool - , rulesYaml :: Maybe String - , outPath :: Maybe String + , rulesPath :: String + , outputFile :: Maybe String , single :: Bool + , json :: Bool + , inputFile :: Maybe FilePath + , maxDepth :: Int + , maxGrowthFactor :: Int } - deriving (Generic, Show, ParseRecord, Read, ParseField) + deriving (Show) -instance ParseFields CLINamedParams where - parseFields _ _ _ _ = - CLINamedParams - <$> parseFields (Just "Print out steps of reduction") (Just "chain") (Just 'c') Nothing - <*> parseFields (Just "Path to the Yaml file with custom rules") (Just "rules-yaml") Nothing Nothing - <*> parseFields (Just "Output file path (defaults to stdout)") (Just "output") (Just 'o') Nothing - <*> parseFields (Just "Print a single normlized expression") (Just "single") (Just 's') Nothing +data CLI'DataizePhi = CLI'DataizePhi + { rulesPath :: String + , inputFile :: Maybe FilePath + , outputFile :: Maybe String + , recursive :: Bool + , chain :: Bool + } + deriving (Show) -data CLIOptions = CLIOptions CLINamedParams (Maybe FilePath) - deriving (Generic, Show, ParseRecord) +data CLI'MetricsPhi = CLI'MetricsPhi + { inputFile :: Maybe FilePath + , outputFile :: Maybe FilePath + , bindingsPath :: Maybe String + } + deriving (Show) +newtype CLI'ReportPhi = CLI'ReportPhi + { configFile :: FilePath + } + deriving (Show) + +data CLI + = CLI'TransformPhi' CLI'TransformPhi + | CLI'DataizePhi' CLI'DataizePhi + | CLI'MetricsPhi' CLI'MetricsPhi + | CLI'ReportPhi' CLI'ReportPhi + deriving (Show) + +fileMetavarName :: String +fileMetavarName = "FILE" + +data MetavarName = MetavarName + { file :: String + , int :: String + , path :: String + } + +metavarName :: MetavarName +metavarName = + MetavarName + { file = "FILE" + , int = "INT" + , path = "PATH" + } + +data Metavar a b = Metavar + { file :: Mod a b + , int :: Mod a b + , path :: Mod a b + } + +metavar :: (HasMetavar a) => Metavar a b +metavar = + Metavar + { file = Optparse.metavar metavarName.file + , int = Optparse.metavar metavarName.int + , path = Optparse.metavar metavarName.path + } + +newtype OptionName = OptionName + { bindingsPath :: String + } + +optionName :: OptionName +optionName = + OptionName + { bindingsPath = "bindings-path" + } + +outputFileOption :: Parser (Maybe String) +outputFileOption = optional $ strOption (long "output-file" <> short 'o' <> metavar.file <> help [i|Output to #{fileMetavarName}. When this option is not specified, output to stdout.|]) + +inputFileArg :: Parser (Maybe String) +inputFileArg = optional $ strArgument (metavar.file <> help [i|#{fileMetavarName} to read input from. When no #{fileMetavarName} is specified, read from stdin.|]) + +jsonSwitch :: Parser Bool +jsonSwitch = switch (long "json" <> short 'j' <> help "Output JSON.") + +bindingsPathOption :: Parser (Maybe String) +bindingsPathOption = + optional $ + strOption + ( long optionName.bindingsPath + <> short 'b' + <> metavar.path + <> help + let path' = metavarName.path + in [iii| + Report metrics for bindings of a formation accessible in a program by the #{path'}. + When this option is not specified, metrics for bindings are not reported. + Example of a #{path'}: 'org.eolang'. + |] + ) + +data CommandParser = CommandParser + { metrics :: Parser CLI'MetricsPhi + , transform :: Parser CLI'TransformPhi + , dataize :: Parser CLI'DataizePhi + , report :: Parser CLI'ReportPhi + } + +commandParser :: CommandParser +commandParser = + CommandParser{..} + where + metrics = do + inputFile <- inputFileArg + outputFile <- outputFileOption + bindingsPath <- bindingsPathOption + pure CLI'MetricsPhi{..} + + transform = do + rulesPath <- + let file' = metavarName.file + in strOption (long "rules" <> short 'r' <> metavar.file <> help [i|#{file'} with user-defined rules. Must be specified.|]) + chain <- switch (long "chain" <> short 'c' <> help "Output transformation steps.") + json <- jsonSwitch + outputFile <- outputFileOption + single <- switch (long "single" <> short 's' <> help "Output a single expression.") + maxDepth <- + let maxValue = 10 + in option auto (long "max-depth" <> metavar.int <> value maxValue <> help [i|Maximum depth of rules application. Defaults to #{maxValue}.|]) + maxGrowthFactor <- + let maxValue = 10 + in option auto (long "max-growth-factor" <> metavar.int <> value maxValue <> help [i|The factor by which to allow the input term to grow before stopping. Defaults to #{maxValue}.|]) + inputFile <- inputFileArg + pure CLI'TransformPhi{..} + dataize = do + rulesPath <- strOption (long "rules" <> short 'r' <> metavar.file <> help [i|#{fileMetavarName} with user-defined rules. Must be specified.|]) + inputFile <- inputFileArg + outputFile <- outputFileOption + recursive <- switch (long "recursive" <> help "Apply dataization + normalization recursively.") + chain <- switch (long "chain" <> help "Display all the intermediate steps.") + pure CLI'DataizePhi{..} + report = do + configFile <- + let file' = metavarName.file + in strOption (long "config" <> short 'c' <> metavar.file <> help [i|The #{file'} with a report configuration.|]) + pure CLI'ReportPhi{..} + +data CommandParserInfo = CommandParserInfo + { metrics :: ParserInfo CLI + , transform :: ParserInfo CLI + , dataize :: ParserInfo CLI + , report :: ParserInfo CLI + } + +commandParserInfo :: CommandParserInfo +commandParserInfo = + CommandParserInfo + { metrics = info (CLI'MetricsPhi' <$> commandParser.metrics) (progDesc "Collect metrics for a PHI program.") + , transform = info (CLI'TransformPhi' <$> commandParser.transform) (progDesc "Transform a PHI program.") + , dataize = info (CLI'DataizePhi' <$> commandParser.dataize) (progDesc "Dataize a PHI program.") + , report = info (CLI'ReportPhi' <$> commandParser.report) (progDesc "Generate reports about initial and normalized PHI programs.") + } + +data CommandNames = CommandNames + { transform :: String + , metrics :: String + , dataize :: String + , report :: String + } + +commandNames :: CommandNames +commandNames = + CommandNames + { transform = "transform" + , metrics = "metrics" + , dataize = "dataize" + , report = "report" + } + +cli :: Parser CLI +cli = + hsubparser + ( command commandNames.transform commandParserInfo.transform + <> command commandNames.metrics commandParserInfo.metrics + <> command commandNames.dataize commandParserInfo.dataize + <> command commandNames.report commandParserInfo.report + ) + +cliOpts :: ParserInfo CLI +cliOpts = + info + (cli <**> helper) + (fullDesc <> progDesc "Work with PHI expressions.") + +data StructuredJSON = StructuredJSON + { input :: String + , output :: [[(String, String)]] + } + deriving (Generic, ToJSON) + +encodeToJSONString :: (ToJSON a) => a -> String +encodeToJSONString = TL.unpack . toLazyText . encodePrettyToTextBuilder' defConfig{confIndent = Spaces 2} + +pprefs :: ParserPrefs +pprefs = prefs (showHelpOnEmpty <> showHelpOnError) + +data CLI'Exception + = NotAFormation {path :: String, bindingsPath :: String} + | FileDoesNotExist {file :: FilePath} + | CouldNotRead {message :: String} + | CouldNotParse {message :: String} + | CouldNotNormalize + | Impossible {message :: String} + deriving anyclass (Exception) + +instance Show CLI'Exception where + show :: CLI'Exception -> String + show = \case + NotAFormation{..} -> [i|Could not find bindings at path '#{bindingsPath}' because an object at '#{path}' is not a formation.|] + FileDoesNotExist{..} -> [i|File '#{file}' does not exist.|] + CouldNotRead{..} -> [i|Could not read the program:\n#{message}|] + CouldNotParse{..} -> [i|An error occurred when parsing the input program:\n#{message}|] + CouldNotNormalize -> [i|Could not normalize the program.|] + Impossible{..} -> message + +getFile :: Maybe FilePath -> IO (Maybe String) +getFile = \case + Nothing -> pure Nothing + Just file' -> + doesFileExist file' >>= \case + True -> pure (Just file') + False -> throw $ FileDoesNotExist file' + +getProgram :: Maybe FilePath -> IO Program +getProgram inputFile = do + inputFile' <- getFile inputFile + src <- maybe getContents' readFile inputFile' `catch` (throw . CouldNotRead . show @SomeException) + case parseProgram src of + Left err -> throw $ CouldNotParse err + Right program -> pure program + +getLoggers :: Maybe FilePath -> IO (String -> IO (), String -> IO ()) +getLoggers outputFile = do + handle <- maybe (pure stdout) (`openFile` WriteMode) outputFile + pure + ( \x -> hPutStrLn handle x >> hFlush handle + , \x -> hPutStr handle x >> hFlush handle + ) + +-- >>> flip getMetrics' (Just "a.b") "{⟦ a ↦ ⟦ b ↦ ⟦ c ↦ ∅, d ↦ ⟦ φ ↦ ξ.ρ.c ⟧ ⟧, e ↦ ξ.b(c ↦ ⟦⟧).d ⟧ ⟧}" +-- Right (ProgramMetrics {bindingsByPathMetrics = Just (BindingsByPathMetrics {path = ["a","b"], bindingsMetrics = [BindingMetrics {name = "d", metrics = Metrics {dataless = 0, applications = 0, formations = 1, dispatches = 2}}]}), programMetrics = Metrics {dataless = 1, applications = 1, formations = 5, dispatches = 4}}) +getMetrics' :: Program -> Maybe String -> Either CLI'Exception ProgramMetrics +getMetrics' program bindingsPath = do + let metrics = getProgramMetrics program (splitPath <$> bindingsPath) + case metrics of + Left path -> + ( case bindingsPath of + Nothing -> + let + bindingsPath' = optionName.bindingsPath + path' = metavarName.path + in + Left $ + Impossible + [iii| + Impossible happened! + The option #{bindingsPath'} was not specified yet there were errors finding attributes by #{path'}. + |] + Just bindingsPath' -> Left $ NotAFormation (intercalate "." path) bindingsPath' + ) + Right metrics' -> pure metrics' + +getMetrics :: Maybe String -> Maybe FilePath -> IO ProgramMetrics +getMetrics bindingsPath inputFile = do + program <- getProgram inputFile + either throw pure (getMetrics' program bindingsPath) + main :: IO () main = do - opts <- getRecord "Normalizer" - let (CLIOptions params inPath) = opts - let (CLINamedParams{..}) = params - case rulesYaml of - Just path -> do - handle <- maybe (pure stdout) (`openFile` WriteMode) outPath - let logStr = hPutStr handle - let logStrLn = hPutStrLn handle - ruleSet <- parseRuleSetFromFile path - unless single $ logStrLn ruleSet.title - src <- maybe getContents readFile inPath - let progOrError = parseProgram src - case progOrError of - Left err -> error ("An error occurred parsing the input program: " <> err) - Right input@(Program bindings) -> do - let results - | chain = applyRulesChain (Context (convertRule <$> ruleSet.rules) [Formation bindings]) (Formation bindings) - | otherwise = pure <$> applyRules (Context (convertRule <$> ruleSet.rules) [Formation bindings]) (Formation bindings) - uniqueResults = nub results - totalResults = length uniqueResults - when (totalResults == 0) $ error "Could not normalize the program" - if single - then logStrLn (printTree (head uniqueResults)) - else do - logStrLn "Input:" - logStrLn (printTree input) - logStrLn "====================================================" - forM_ (zip [1 ..] uniqueResults) $ \(i, steps) -> do - logStrLn $ - "Result " <> show i <> " out of " <> show totalResults <> ":" - let n = length steps - forM_ (zip [1 ..] steps) $ \(k, step) -> do - when chain $ - logStr ("[ " <> show k <> " / " <> show n <> " ]") - logStrLn (printTree step) - logStrLn "----------------------------------------------------" - hClose handle - -- TODO #48:15m still need to consider `chain` (should rewrite/change defaultMain to mainWithOptions) - Nothing -> defaultMain + opts <- customExecParser pprefs cliOpts + let printAsProgramOrAsObject = \case + Formation bindings' -> printTree $ Program bindings' + x -> printTree x + case opts of + CLI'MetricsPhi' CLI'MetricsPhi{..} -> do + (logStrLn, _) <- getLoggers outputFile + metrics <- getMetrics bindingsPath inputFile + logStrLn $ encodeToJSONString metrics + CLI'TransformPhi' CLI'TransformPhi{..} -> do + program' <- getProgram inputFile + (logStrLn, logStr) <- getLoggers outputFile + ruleSet <- parseRuleSetFromFile rulesPath + unless (single || json) $ logStrLn ruleSet.title + let Program bindings = program' + uniqueResults + | chain = applyRulesChainWith limits ctx (Formation bindings) + | otherwise = pure . ("",) <$> applyRulesWith limits ctx (Formation bindings) + where + limits = ApplicationLimits maxDepth (maxGrowthFactor * objectSize (Formation bindings)) + ctx = defaultContext (convertRuleNamed <$> ruleSet.rules) (Formation bindings) + totalResults = length uniqueResults + when (null uniqueResults || null (head uniqueResults)) (throw CouldNotNormalize) + if + | single && json -> + logStrLn + . encodeToJSONString + . printAsProgramOrAsObject + $ snd (head (head uniqueResults)) + | single -> + logStrLn + . printAsProgramOrAsObject + $ snd (head (head uniqueResults)) + | json -> + logStrLn . encodeToJSONString $ + StructuredJSON + { input = printTree program' + , output = (propagateName1 printAsProgramOrAsObject <$>) <$> uniqueResults + } + | otherwise -> do + logStrLn "Input:" + logStrLn (printTree program') + logStrLn "====================================================" + forM_ (zip [1 ..] uniqueResults) $ \(index, steps) -> do + logStrLn $ + "Result " <> show index <> " out of " <> show totalResults <> ":" + let n = length steps + forM_ (zip [1 ..] steps) $ \(k, (appliedRuleName, step)) -> do + when chain $ + logStr ("[ " <> show k <> " / " <> show n <> " ] " <> appliedRuleName <> ": ") + logStrLn . printAsProgramOrAsObject $ step + logStrLn "----------------------------------------------------" + CLI'DataizePhi' CLI'DataizePhi{..} -> do + (logStrLn, _logStr) <- getLoggers outputFile + program' <- getProgram inputFile + ruleSet <- parseRuleSetFromFile rulesPath + let (Program bindings) = program' + let inputObject = Formation bindings + let ctx = defaultContext (convertRuleNamed <$> ruleSet.rules) inputObject + ( if chain + then do + let dataizeChain + | recursive = dataizeRecursivelyChain + | otherwise = dataizeStepChain + forM_ (dataizeChain ctx inputObject) $ \case + (msg, Left obj) -> logStrLn (msg ++ ": " ++ printTree obj) + (msg, Right (Bytes bytes)) -> logStrLn (msg ++ ": " ++ bytes) + else do + let dataize + -- This should be moved to a separate subcommand + | recursive = dataizeRecursively + | otherwise = dataizeStep + case dataize ctx inputObject of + Left obj -> logStrLn (printAsProgramOrAsObject obj) + Right (Bytes bytes) -> logStrLn bytes + ) + CLI'ReportPhi' CLI'ReportPhi{..} -> do + reportConfig <- decodeFileThrow configFile + + programReports <- forM reportConfig.items $ \item -> do + metricsPhi <- getMetrics item.bindingsPathPhi (Just item.phi) + metricsPhiNormalized <- getMetrics item.bindingsPathPhiNormalized (Just item.phiNormalized) + pure $ makeProgramReport reportConfig item metricsPhi metricsPhiNormalized + + css <- maybe (pure reportCSS) readFile (reportConfig.input >>= (.css)) + js <- maybe (pure reportJS) readFile (reportConfig.input >>= (.js)) + + let report = makeReport reportConfig programReports + + reportConfigHtml = + ReportHtml.ReportConfig + { expectedMetricsChange = reportConfig.expectedMetricsChange + , format = + ReportFormat'Html + { .. + } + } + reportHtml = toStringReport reportConfigHtml report + + reportJson = encodeToJSONString report + + reportConfigMarkdown = + ReportHtml.ReportConfig + { expectedMetricsChange = reportConfig.expectedMetricsChange + , format = ReportFormat'Markdown + } + reportMarkdown = toStringReport reportConfigMarkdown report + + forM_ @[] + [ (x, y) + | (Just x, y) <- + [ (reportConfig.output.html, reportHtml) + , (reportConfig.output.json, reportJson) + , (reportConfig.output.markdown, reportMarkdown) + ] + ] + $ \(path, reportString) -> do + createDirectoryIfMissing True (takeDirectory path) + writeFile path reportString diff --git a/eo-phi-normalizer.cabal b/eo-phi-normalizer.cabal --- a/eo-phi-normalizer.cabal +++ b/eo-phi-normalizer.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: eo-phi-normalizer -version: 0.2.0 +version: 0.3.0 synopsis: Command line normalizer of 𝜑-calculus expressions. description: Please see the README on GitHub at homepage: https://github.com/objectionary/eo-phi-normalizer#readme @@ -20,6 +20,8 @@ README.md CHANGELOG.md grammar/EO/Phi/Syntax.cf + report/main.js + report/styles.css source-repository head type: git @@ -34,8 +36,12 @@ library exposed-modules: Language.EO.Phi + Language.EO.Phi.Dataize Language.EO.Phi.Metrics.Collect + Language.EO.Phi.Metrics.Data Language.EO.Phi.Normalize + Language.EO.Phi.Report.Data + Language.EO.Phi.Report.Html Language.EO.Phi.Rules.Common Language.EO.Phi.Rules.PhiPaper Language.EO.Phi.Rules.Yaml @@ -44,6 +50,7 @@ Language.EO.Phi.Syntax.Lex Language.EO.Phi.Syntax.Par Language.EO.Phi.Syntax.Print + Language.EO.Phi.TH other-modules: Paths_eo_phi_normalizer hs-source-dirs: @@ -60,16 +67,22 @@ aeson , array >=0.5.5.0 , base >=4.7 && <5 + , blaze-html + , blaze-markup , directory + , file-embed , filepath , generic-lens , lens , mtl + , scientific , string-interpolate + , template-haskell + , text , yaml default-language: Haskell2010 -executable normalize-phi +executable normalizer main-is: Main.hs other-modules: Paths_eo_phi_normalizer @@ -85,24 +98,33 @@ BNFC:bnfc >=2.9.4.1 build-depends: aeson + , aeson-pretty , array >=0.5.5.0 , base >=4.7 && <5 + , blaze-html + , blaze-markup , directory , eo-phi-normalizer + , file-embed , filepath , generic-lens , lens , mtl - , optparse-generic + , optparse-applicative + , scientific , string-interpolate + , template-haskell + , text , yaml default-language: Haskell2010 -test-suite eo-phi-normalizer-test +test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + Language.EO.Phi.DataizeSpec Language.EO.PhiSpec + Language.EO.Rules.PhiPaperSpec Language.EO.YamlSpec Test.EO.Phi Test.EO.Yaml @@ -119,17 +141,24 @@ build-tool-depends: BNFC:bnfc >=2.9.4.1 build-depends: - aeson + QuickCheck + , aeson , array >=0.5.5.0 , base >=4.7 && <5 + , blaze-html + , blaze-markup , directory , eo-phi-normalizer + , file-embed , filepath , generic-lens , hspec , hspec-discover , lens , mtl + , scientific , string-interpolate + , template-haskell + , text , yaml default-language: Haskell2010 diff --git a/grammar/EO/Phi/Syntax.cf b/grammar/EO/Phi/Syntax.cf --- a/grammar/EO/Phi/Syntax.cf +++ b/grammar/EO/Phi/Syntax.cf @@ -4,6 +4,9 @@ -- -- This is a non-ambiguous grammar for φ-programs. +comment "//" ; +comment "/*" "*/" ; + token Bytes ({"--"} | ["0123456789ABCDEF"] ["0123456789ABCDEF"] {"-"} | ["0123456789ABCDEF"] ["0123456789ABCDEF"] ({"-"} ["0123456789ABCDEF"] ["0123456789ABCDEF"])+) ; token Function upper (char - [" \r\n\t,.|':;!-?][}{)(⟧⟦"])* ; token LabelId lower (char - [" \r\n\t,.|':;!?][}{)(⟧⟦"])* ; @@ -22,11 +25,13 @@ MetaObject. Object ::= MetaId ; MetaFunction. Object ::= MetaFunctionName "(" Object ")" ; -AlphaBinding. Binding ::= Attribute "↦" Object ; -EmptyBinding. Binding ::= Attribute "↦" "∅" ; -DeltaBinding. Binding ::= "Δ" "⤍" Bytes ; -LambdaBinding. Binding ::= "λ" "⤍" Function ; -MetaBindings. Binding ::= MetaId ; +AlphaBinding. Binding ::= Attribute "↦" Object ; +EmptyBinding. Binding ::= Attribute "↦" "∅" ; +DeltaBinding. Binding ::= "Δ" "⤍" Bytes ; +DeltaEmptyBinding. Binding ::= "Δ" "⤍" "∅" ; +LambdaBinding. Binding ::= "λ" "⤍" Function ; +MetaBindings. Binding ::= MetaId ; +MetaDeltaBinding. Binding ::= "Δ" "⤍" MetaId ; separator Binding "," ; Phi. Attribute ::= "φ" ; -- decoratee object diff --git a/report/main.js b/report/main.js new file mode 100644 --- /dev/null +++ b/report/main.js @@ -0,0 +1,65 @@ +document.addEventListener("click", function (c) { + try { + function h(b, a) { + return b.nodeName === a ? b : h(b.parentNode, a); + } + var v = c.shiftKey || c.altKey, + d = h(c.target, "TH"), + m = d.parentNode, + n = m.parentNode, + g = n.parentNode; + function p(b) { + var a; + return v + ? b.dataset.sortAlt + : null !== (a = b.dataset.sort) && void 0 !== a + ? a + : b.textContent; + } + if ( + "THEAD" === n.nodeName && + g.classList.contains("sortable") && + !d.classList.contains("no-sort") + ) { + var q, + f = m.cells, + r = parseInt(d.dataset.sortTbr); + for (c = 0; c < f.length; c++) + f[c] === d + ? (q = parseInt(d.dataset.sortCol) || c) + : f[c].setAttribute("aria-sort", "none"); + f = "descending"; + if ( + "descending" === d.getAttribute("aria-sort") || + (g.classList.contains("asc") && + "ascending" !== d.getAttribute("aria-sort")) + ) + f = "ascending"; + d.setAttribute("aria-sort", f); + var w = "ascending" === f, + x = g.classList.contains("n-last"), + t = function (b, a, e) { + a = p(a.cells[e]); + b = p(b.cells[e]); + if (x) { + if ("" === a && "" !== b) return -1; + if ("" === b && "" !== a) return 1; + } + e = Number(a) - Number(b); + a = isNaN(e) ? a.localeCompare(b) : e; + return w ? -a : a; + }; + for (c = 0; c < g.tBodies.length; c++) { + var k = g.tBodies[c], + u = [].slice.call(k.rows, 0); + u.sort(function (b, a) { + var e = t(b, a, q); + return 0 !== e || isNaN(r) ? e : t(b, a, r); + }); + var l = k.cloneNode(); + l.append.apply(l, u); + g.replaceChild(l, k); + } + } + } catch (h) {} +}); diff --git a/report/styles.css b/report/styles.css new file mode 100644 --- /dev/null +++ b/report/styles.css @@ -0,0 +1,105 @@ +/* +* Prefixed by https://autoprefixer.github.io +* PostCSS: v8.4.14, +* Autoprefixer: v10.4.7 +* Browsers: last 4 version +*/ + +/* +source: https://cdn.jsdelivr.net/gh/tofsjonas/sortable@latest/sortable.min.css +repo: https://github.com/tofsjonas/sortable +*/ + +.sortable thead th:not(.no-sort) { + cursor: pointer; +} +.sortable thead th:not(.no-sort)::after, +.sortable thead th:not(.no-sort)::before { + -webkit-transition: color 0.1s ease-in-out; + -o-transition: color 0.1s ease-in-out; + transition: color 0.1s ease-in-out; + font-size: 1.2em; + color: rgba(0, 0, 0, 0); +} +.sortable thead th:not(.no-sort)::after { + margin-left: 3px; + content: "▸"; +} +.sortable thead th:not(.no-sort):hover::after { + color: inherit; +} +.sortable thead th:not(.no-sort)[aria-sort="descending"]::after { + color: inherit; + content: "▾"; +} +.sortable thead th:not(.no-sort)[aria-sort="ascending"]::after { + color: inherit; + content: "▴"; +} +.sortable thead th:not(.no-sort).indicator-left::after { + content: ""; +} +.sortable thead th:not(.no-sort).indicator-left::before { + margin-right: 3px; + content: "▸"; +} +.sortable thead th:not(.no-sort).indicator-left:hover::before { + color: inherit; +} +.sortable thead th:not(.no-sort).indicator-left[aria-sort="descending"]::before { + color: inherit; + content: "▾"; +} +.sortable thead th:not(.no-sort).indicator-left[aria-sort="ascending"]::before { + color: inherit; + content: "▴"; +} +.sortable { + --stripe-color: #e4e4e4; + --th-color: #fff; + --th-bg: #808080; + --td-color: #000; + --td-on-stripe-color: #000; + border-spacing: 0; +} +.sortable tbody tr:nth-child(odd) { + background-color: var(--stripe-color); + color: var(--td-on-stripe-color); +} +.sortable thead th { + background: var(--th-bg); + color: var(--th-color); + font-weight: normal; + text-align: left; + text-transform: capitalize; + vertical-align: baseline; + white-space: nowrap; +} + +.sortable td { + color: var(--td-color); +} + +.sortable td, +.sortable th { + padding: 10px; + border: 1px solid black; +} + +.sortable td.number { + text-align: right; +} + +.sortable thead th { + text-align: center; +} + +.sortable td.bad { + background-color: orangered; +} +.sortable td.good { + background-color: greenyellow; +} +.sortable td.not-applicable { + background-color: blueviolet; +} diff --git a/src/Language/EO/Phi/Dataize.hs b/src/Language/EO/Phi/Dataize.hs new file mode 100644 --- /dev/null +++ b/src/Language/EO/Phi/Dataize.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +module Language.EO.Phi.Dataize (dataizeStep, dataizeRecursively, dataizeStepChain, dataizeRecursivelyChain) where + +import Control.Arrow (ArrowChoice (left)) +import Data.List (find) +import Data.Maybe (listToMaybe) +import Data.String.Interpolate (i) +import Language.EO.Phi (printTree) +import Language.EO.Phi.Rules.Common (Context, applyRules, applyRulesChain, bytesToInt, extendContextWith, intToBytes) +import Language.EO.Phi.Syntax.Abs ( + AlphaIndex (AlphaIndex), + Attribute (Alpha, Phi, Rho), + Binding (AlphaBinding, DeltaBinding, LambdaBinding), + Bytes (Bytes), + Function (Function), + Object (Application, Formation, ObjectDispatch, Termination), + ) + +-- | Perform one step of dataization to the object (if possible). +dataizeStep :: Context -> Object -> Either Object Bytes +dataizeStep ctx obj@(Formation bs) + | Just (DeltaBinding bytes) <- find isDelta bs = Right bytes + | Just (LambdaBinding (Function funcName)) <- find isLambda bs = Left (fst $ evaluateBuiltinFun ctx funcName obj ()) + | Just (AlphaBinding Phi decoratee) <- find isPhi bs = dataizeStep (extendContextWith obj ctx) decoratee + | otherwise = Left obj + where + isDelta (DeltaBinding _) = True + isDelta _ = False + isLambda (LambdaBinding _) = True + isLambda _ = False + isPhi (AlphaBinding Phi _) = True + isPhi _ = False +dataizeStep ctx (Application obj bindings) = case dataizeStep ctx obj of + Left dataized -> Left $ Application dataized bindings + Right _ -> error ("Application on bytes upon dataizing:\n " <> printTree obj) +dataizeStep ctx (ObjectDispatch obj attr) = case dataizeStep ctx obj of + Left dataized -> Left $ ObjectDispatch dataized attr + Right _ -> error ("Dispatch on bytes upon dataizing:\n " <> printTree obj) +dataizeStep _ obj = Left obj + +-- | State of evaluation is not needed yet, but it might be in the future +type EvaluationState = () + +-- | Recursively perform normalization and dataization until we get bytes in the end. +dataizeRecursively :: Context -> Object -> Either Object Bytes +dataizeRecursively ctx obj = case applyRules ctx obj of + [normObj] -> case dataizeStep ctx normObj of + Left stillObj + | stillObj == normObj -> Left stillObj -- dataization changed nothing + | otherwise -> dataizeRecursively ctx stillObj -- partially dataized + Right bytes -> Right bytes + objs -> error errMsg -- Left Termination + where + errMsg = + "Expected 1 result from normalization but got " + <> show (length objs) + <> ":\n" + <> unlines (map ((" - " ++) . printTree) objs) + <> "\nFor the input:\n " + <> printTree obj + +-- | Perform one step of dataization to the object (if possible), reporting back individiual steps. +dataizeStepChain :: Context -> Object -> [(String, Either Object Bytes)] +dataizeStepChain ctx obj@(Formation bs) + | Just (DeltaBinding bytes) <- listToMaybe [b | b@(DeltaBinding _) <- bs] = [("Found bytes", Right bytes)] + | Just (LambdaBinding (Function funcName)) <- listToMaybe [b | b@(LambdaBinding _) <- bs] = + let evaluationChain = evaluateBuiltinFunChain ctx funcName obj () + in ("Evaluating lambda '" <> funcName <> "'", Left obj) : map (fmap Left . fst) evaluationChain + | Just (AlphaBinding Phi decoratee) <- listToMaybe [b | b@(AlphaBinding Phi _) <- bs] = + ("Dataizing inside phi", Left decoratee) : dataizeStepChain (extendContextWith obj ctx) decoratee + | otherwise = [("No change to formation", Left obj)] +dataizeStepChain ctx (Application obj bindings) = ("Dataizing inside application", Left obj) : map (fmap (left (`Application` bindings))) (dataizeStepChain ctx obj) +dataizeStepChain ctx (ObjectDispatch obj attr) = ("Dataizing inside dispatch", Left obj) : map (fmap (left (`ObjectDispatch` attr))) (dataizeStepChain ctx obj) +dataizeStepChain _ obj = [("Nothing to dataize", Left obj)] + +-- | Recursively perform normalization and dataization until we get bytes in the end, +-- reporting intermediate steps +dataizeRecursivelyChain :: Context -> Object -> [(String, Either Object Bytes)] +dataizeRecursivelyChain ctx obj = case applyRulesChain ctx obj of + [[]] -> [("No rules applied", Left obj)] + [rulesChain] -> + let (_lastRule, normObj) = last rulesChain + stepChain = dataizeStepChain ctx normObj + in map (fmap Left) rulesChain + ++ case stepChain of + [] -> [] + (last -> (_, Left stillObj)) + | stillObj == normObj -> stepChain -- dataization changed nothing + | otherwise -> stepChain ++ dataizeRecursivelyChain ctx stillObj -- partially dataized + bytesAndRest -> bytesAndRest + chains -> [(errMsg, Left Termination)] + where + errMsg = + "Expected 1 chain from normalization but got " + <> show (length chains) + <> ":\n" + <> unlines (map (unlines . map (\(name, object) -> " - " ++ name ++ ": " ++ printTree object)) chains) + <> "\nFor the input:\n " + <> printTree obj + +-- | Given normalization context, a function on data (bytes interpreted as integers), an object, +-- and the current state of evaluation, returns the new object and a possibly modified state along with intermediate steps. +evaluateDataizationFunChain :: Context -> (Int -> Int -> Int) -> Object -> EvaluationState -> [((String, Object), EvaluationState)] +evaluateDataizationFunChain ctx func obj _state = map (,()) result + where + lhs = let o_rho = ObjectDispatch obj Rho in ("Evaluating LHS", Left o_rho) : dataizeRecursivelyChain ctx o_rho + rhs = let o_a0 = ObjectDispatch obj (Alpha (AlphaIndex "α0")) in ("Evaluating RHS", Left o_a0) : dataizeRecursivelyChain ctx o_a0 + lhsBytes = [(msg, bytes) | (msg, Right bytes) <- lhs] + rhsBytes = [(msg, bytes) | (msg, Right bytes) <- rhs] + lhsObjects = [(msg, object) | (msg, Left object) <- lhs] + rhsObjects = [(msg, object) | (msg, Left object) <- rhs] + result = case (lhsBytes, rhsBytes) of + ([(_, l)], [(_, r)]) -> + let (Bytes bytes) = intToBytes (bytesToInt r `func` bytesToInt l) + in lhsObjects + ++ rhsObjects + ++ [("Evaluated function", [i|Φ.org.eolang.float(Δ ⤍ #{bytes})|])] + _ -> lhsObjects ++ rhsObjects ++ [("Couldn't find bytes in one or both of LHS and RHS", Termination)] + +-- | Like `evaluateDataizationFunChain` but specifically for the built-in functions. +-- This function is not safe. It returns undefined for unknown functions +evaluateBuiltinFunChain :: Context -> String -> Object -> EvaluationState -> [((String, Object), EvaluationState)] +evaluateBuiltinFunChain ctx "Plus" = evaluateDataizationFunChain ctx (+) +evaluateBuiltinFunChain ctx "Times" = evaluateDataizationFunChain ctx (*) +evaluateBuiltinFunChain _ _ = const $ const [(undefined, ())] + +-- | Given normalization context, a function on data (bytes interpreted as integers), an object, +-- and the current state of evaluation, returns the new object and a possibly modified state. +evaluateDataizationFun :: Context -> (Int -> Int -> Int) -> Object -> EvaluationState -> (Object, EvaluationState) +evaluateDataizationFun ctx func obj _state = (result, ()) + where + lhs = dataizeRecursively ctx (ObjectDispatch obj Rho) + rhs = dataizeRecursively ctx (ObjectDispatch obj (Alpha (AlphaIndex "α0"))) + result = case (lhs, rhs) of + (Right l, Right r) -> let (Bytes bytes) = intToBytes (bytesToInt r `func` bytesToInt l) in [i|Φ.org.eolang.float(Δ ⤍ #{bytes})|] + _ -> Termination + +-- | Like `evaluateDataizationFun` but specifically for the built-in functions. +-- This function is not safe. It returns undefined for unknown functions +evaluateBuiltinFun :: Context -> String -> Object -> EvaluationState -> (Object, EvaluationState) +evaluateBuiltinFun ctx "Plus" = evaluateDataizationFun ctx (+) +evaluateBuiltinFun ctx "Times" = evaluateDataizationFun ctx (*) +evaluateBuiltinFun _ "Package" = (,) -- Ignore package for now (See #203) +evaluateBuiltinFun _ _ = const $ const (undefined, ()) diff --git a/src/Language/EO/Phi/Metrics/Collect.hs b/src/Language/EO/Phi/Metrics/Collect.hs --- a/src/Language/EO/Phi/Metrics/Collect.hs +++ b/src/Language/EO/Phi/Metrics/Collect.hs @@ -1,83 +1,193 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Language.EO.Phi.Metrics.Collect where import Control.Lens ((+=)) -import Control.Monad (forM_) -import Control.Monad.State (State, execState) -import Data.Aeson (FromJSON) +import Control.Monad.State (State, execState, runState) +import Data.Foldable (forM_) import Data.Generics.Labels () -import GHC.Generics (Generic) +import Data.Traversable (forM) +import Language.EO.Phi.Metrics.Data (BindingMetrics (..), BindingsByPathMetrics (..), MetricsCount, ObjectMetrics (..), Path, ProgramMetrics (..)) import Language.EO.Phi.Rules.Common () import Language.EO.Phi.Syntax.Abs -data Metrics = Metrics - { dataless :: Int - , applications :: Int - , formations :: Int - , dispatches :: Int - } - deriving (Generic, Show, FromJSON, Eq) +count :: (a -> Bool) -> [a] -> Int +count x = length . filter x -defaultMetrics :: Metrics -defaultMetrics = - Metrics - { dataless = 0 - , applications = 0 - , formations = 0 - , dispatches = 0 - } +getHeight :: [Binding] -> [Int] -> Int +getHeight bindings heights + | hasDeltaBinding = 1 + | otherwise = heightAttributes + where + heightAttributes = + case heights of + [] -> 0 + _ -> minimum heights + 1 + hasDeltaBinding = not $ null [undefined | DeltaBinding _ <- bindings] -collectMetrics :: (Inspectable a) => a -> Metrics -collectMetrics a = execState (inspect a) defaultMetrics +countDataless :: Int -> Int +countDataless x + | x == 0 || x > 2 = 1 + | otherwise = 0 class Inspectable a where - inspect :: a -> State Metrics () - -instance Inspectable Program where - inspect (Program binding) = forM_ binding inspect + inspect :: a -> State MetricsCount Int instance Inspectable Binding where + inspect :: Binding -> State MetricsCount Int inspect = \case - AlphaBinding attr obj -> do - inspect attr + AlphaBinding _ obj -> do inspect obj - EmptyBinding attr -> do - #dataless += 1 - inspect attr - DeltaBinding _ -> pure () - LambdaBinding _ -> #dataless += 1 - MetaBindings _ -> pure () - -instance Inspectable Attribute where - inspect = \case - Phi -> pure () - Rho -> pure () - Sigma -> pure () - VTX -> pure () - Label _ -> pure () - Alpha _ -> pure () - MetaAttr _ -> pure () + _ -> pure 0 instance Inspectable Object where + inspect :: Object -> State MetricsCount Int inspect = \case Formation bindings -> do #formations += 1 - forM_ bindings inspect + heights <- forM bindings inspect + let height = getHeight bindings heights + #dataless += countDataless height + pure height Application obj bindings -> do #applications += 1 - inspect obj + _ <- inspect obj forM_ bindings inspect - ObjectDispatch obj attr -> do + pure 0 + ObjectDispatch obj _ -> do #dispatches += 1 - inspect obj - inspect attr - GlobalObject -> pure () - ThisObject -> pure () - Termination -> pure () - MetaObject _ -> pure () - MetaFunction _ _ -> pure () + _ <- inspect obj + pure 0 + _ -> pure 0 + +-- | Get metrics for an object +-- +-- >>> getThisObjectMetrics "⟦ α0 ↦ ξ, α0 ↦ Φ.org.eolang.bytes( Δ ⤍ 00- ) ⟧" +-- Metrics {dataless = 0, applications = 1, formations = 1, dispatches = 3} +-- +-- >>> getThisObjectMetrics "⟦ α0 ↦ ξ, Δ ⤍ 00- ⟧" +-- Metrics {dataless = 0, applications = 0, formations = 1, dispatches = 0} +-- +-- >>> getThisObjectMetrics "⟦ α0 ↦ ξ, α1 ↦ ⟦ Δ ⤍ 00- ⟧ ⟧" +-- Metrics {dataless = 0, applications = 0, formations = 2, dispatches = 0} +-- +-- >>> getThisObjectMetrics "⟦ α0 ↦ ξ, α1 ↦ ⟦ α2 ↦ ⟦ Δ ⤍ 00- ⟧ ⟧ ⟧" +-- Metrics {dataless = 0, applications = 0, formations = 3, dispatches = 0} +-- +-- >>> getThisObjectMetrics "⟦ Δ ⤍ 00- ⟧" +-- Metrics {dataless = 0, applications = 0, formations = 1, dispatches = 0} +-- +-- >>> getThisObjectMetrics "⟦ α0 ↦ ⟦ α0 ↦ ∅ ⟧ ⟧" +-- Metrics {dataless = 0, applications = 0, formations = 2, dispatches = 0} +-- +-- >>> getThisObjectMetrics "⟦ α0 ↦ ⟦ α0 ↦ ⟦ α0 ↦ ∅ ⟧ ⟧ ⟧" +-- Metrics {dataless = 1, applications = 0, formations = 3, dispatches = 0} +-- +-- >>> getThisObjectMetrics "⟦ α0 ↦ ⟦ α0 ↦ ⟦ α0 ↦ ⟦ α0 ↦ ∅ ⟧ ⟧ ⟧ ⟧" +-- Metrics {dataless = 2, applications = 0, formations = 4, dispatches = 0} +-- +-- >>> getThisObjectMetrics "⟦ org ↦ ⟦ ⟧ ⟧" +-- Metrics {dataless = 1, applications = 0, formations = 2, dispatches = 0} +-- +-- >>> getThisObjectMetrics "⟦ a ↦ ⟦ b ↦ ⟦ c ↦ ∅, d ↦ ⟦ φ ↦ ξ.ρ.c ⟧ ⟧, e ↦ ξ.b(c ↦ ⟦⟧).d ⟧.e ⟧" +-- Metrics {dataless = 1, applications = 1, formations = 5, dispatches = 5} +getThisObjectMetrics :: Object -> MetricsCount +getThisObjectMetrics obj = execState (inspect obj) mempty + +-- | Get an object by a path within a given object. +-- +-- If no object is accessible by the path, return a prefix of the path that led to a non-formation when the remaining path wasn't empty. +-- >>> flip getObjectByPath ["org", "eolang"] "⟦ org ↦ ⟦ eolang ↦ ⟦ x ↦ ⟦ φ ↦ Φ.org.eolang.bool ( α0 ↦ Φ.org.eolang.bytes (Δ ⤍ 01-) ) ⟧, z ↦ ⟦ y ↦ ⟦ x ↦ ∅, φ ↦ ξ.x ⟧, φ ↦ Φ.org.eolang.bool ( α0 ↦ Φ.org.eolang.bytes (Δ ⤍ 01-) ) ⟧, λ ⤍ Package ⟧, λ ⤍ Package ⟧⟧" +-- Right (Formation [AlphaBinding (Label (LabelId "x")) (Formation [AlphaBinding Phi (Application (ObjectDispatch (ObjectDispatch (ObjectDispatch GlobalObject (Label (LabelId "org"))) (Label (LabelId "eolang"))) (Label (LabelId "bool"))) [AlphaBinding (Alpha (AlphaIndex "\945\&0")) (Application (ObjectDispatch (ObjectDispatch (ObjectDispatch GlobalObject (Label (LabelId "org"))) (Label (LabelId "eolang"))) (Label (LabelId "bytes"))) [DeltaBinding (Bytes "01-")])])]),AlphaBinding (Label (LabelId "z")) (Formation [AlphaBinding (Label (LabelId "y")) (Formation [EmptyBinding (Label (LabelId "x")),AlphaBinding Phi (ObjectDispatch ThisObject (Label (LabelId "x")))]),AlphaBinding Phi (Application (ObjectDispatch (ObjectDispatch (ObjectDispatch GlobalObject (Label (LabelId "org"))) (Label (LabelId "eolang"))) (Label (LabelId "bool"))) [AlphaBinding (Alpha (AlphaIndex "\945\&0")) (Application (ObjectDispatch (ObjectDispatch (ObjectDispatch GlobalObject (Label (LabelId "org"))) (Label (LabelId "eolang"))) (Label (LabelId "bytes"))) [DeltaBinding (Bytes "01-")])])]),LambdaBinding (Function "Package")]) +-- +-- >>> flip getObjectByPath ["a"] "⟦ a ↦ ⟦ b ↦ ⟦ c ↦ ∅, d ↦ ⟦ φ ↦ ξ.ρ.c ⟧ ⟧, e ↦ ξ.b(c ↦ ⟦⟧).d ⟧.e ⟧" +-- Right (ObjectDispatch (Formation [AlphaBinding (Label (LabelId "b")) (Formation [EmptyBinding (Label (LabelId "c")),AlphaBinding (Label (LabelId "d")) (Formation [AlphaBinding Phi (ObjectDispatch (ObjectDispatch ThisObject Rho) (Label (LabelId "c")))])]),AlphaBinding (Label (LabelId "e")) (ObjectDispatch (Application (ObjectDispatch ThisObject (Label (LabelId "b"))) [AlphaBinding (Label (LabelId "c")) (Formation [])]) (Label (LabelId "d")))]) (Label (LabelId "e"))) +getObjectByPath :: Object -> Path -> Either Path Object +getObjectByPath object path = + case path of + [] -> Right object + (p : ps) -> + case object of + Formation bindings -> + case objectByPath' of + [] -> Left path + (x : _) -> Right x + where + objectByPath' = + do + x <- bindings + Right obj <- + case x of + AlphaBinding (Alpha (AlphaIndex name)) obj | name == p -> [getObjectByPath obj ps] + AlphaBinding (Label (LabelId name)) obj | name == p -> [getObjectByPath obj ps] + _ -> [Left path] + pure obj + _ -> Left path + +-- | Get metrics for bindings of a formation that is accessible by a path within a given object. +-- +-- If no formation is accessible by the path, return a prefix of the path that led to a non-formation when the remaining path wasn't empty. +-- >>> flip getBindingsByPathMetrics ["a"] "⟦ a ↦ ⟦ b ↦ ⟦ c ↦ ∅, d ↦ ⟦ φ ↦ ξ.ρ.c ⟧ ⟧, e ↦ ξ.b(c ↦ ⟦⟧).d ⟧.e ⟧" +-- Left ["a"] +-- +-- >>> flip getBindingsByPathMetrics ["a"] "⟦ a ↦ ⟦ b ↦ ⟦ c ↦ ∅, d ↦ ⟦ φ ↦ ξ.ρ.c ⟧ ⟧, e ↦ ξ.b(c ↦ ⟦⟧).d ⟧ ⟧" +-- Right (BindingsByPathMetrics {path = ["a"], bindingsMetrics = [BindingMetrics {name = "b", metrics = Metrics {dataless = 0, applications = 0, formations = 2, dispatches = 2}},BindingMetrics {name = "e", metrics = Metrics {dataless = 1, applications = 1, formations = 1, dispatches = 2}}]}) +getBindingsByPathMetrics :: Object -> Path -> Either Path BindingsByPathMetrics +getBindingsByPathMetrics object path = + case getObjectByPath object path of + Right (Formation bindings) -> + let attributes' = flip runState mempty . inspect <$> bindings + (_, objectMetrics) = unzip attributes' + bindingsMetrics = do + x <- zip bindings objectMetrics + case x of + (AlphaBinding (Alpha (AlphaIndex name)) _, metrics) -> [BindingMetrics{..}] + (AlphaBinding (Label (LabelId name)) _, metrics) -> [BindingMetrics{..}] + _ -> [] + in Right $ BindingsByPathMetrics{..} + Right _ -> Left path + Left path' -> Left path' + +-- | Get metrics for an object and for bindings of a formation accessible by a given path. +-- +-- Combine metrics produced by 'getThisObjectMetrics' and 'getBindingsByPathMetrics'. +-- +-- If no formation is accessible by the path, return a prefix of the path that led to a non-formation when the remaining path wasn't empty. +-- >>> flip getObjectMetrics (Just ["a"]) "⟦ a ↦ ⟦ b ↦ ⟦ c ↦ ∅, d ↦ ⟦ φ ↦ ξ.ρ.c ⟧ ⟧, e ↦ ξ.b(c ↦ ⟦⟧).d ⟧.e ⟧" +-- Left ["a"] +-- +-- >>> flip getObjectMetrics (Just ["a"]) "⟦ a ↦ ⟦ b ↦ ⟦ c ↦ ∅, d ↦ ⟦ φ ↦ ξ.ρ.c ⟧ ⟧, e ↦ ξ.b(c ↦ ⟦⟧).d ⟧ ⟧" +-- Right (ObjectMetrics {bindingsByPathMetrics = Just (BindingsByPathMetrics {path = ["a"], bindingsMetrics = [BindingMetrics {name = "b", metrics = Metrics {dataless = 0, applications = 0, formations = 2, dispatches = 2}},BindingMetrics {name = "e", metrics = Metrics {dataless = 1, applications = 1, formations = 1, dispatches = 2}}]}), thisObjectMetrics = Metrics {dataless = 1, applications = 1, formations = 5, dispatches = 4}}) +getObjectMetrics :: Object -> Maybe Path -> Either Path ObjectMetrics +getObjectMetrics object path = do + let thisObjectMetrics = getThisObjectMetrics object + bindingsByPathMetrics <- forM path $ \path' -> getBindingsByPathMetrics object path' + pure ObjectMetrics{..} + +-- | Get metrics for a program and for bindings of a formation accessible by a given path. +-- +-- Combine metrics produced by 'getThisObjectMetrics' and 'getBindingsByPathMetrics'. +-- +-- If no formation is accessible by the path, return a prefix of the path that led to a non-formation when the remaining path wasn't empty. +-- >>> flip getProgramMetrics (Just ["org", "eolang"]) "{⟦ org ↦ ⟦ eolang ↦ ⟦ x ↦ ⟦ φ ↦ Φ.org.eolang.bool ( α0 ↦ Φ.org.eolang.bytes (Δ ⤍ 01-) ) ⟧, z ↦ ⟦ y ↦ ⟦ x ↦ ∅, φ ↦ ξ.x ⟧, φ ↦ Φ.org.eolang.bool ( α0 ↦ Φ.org.eolang.bytes (Δ ⤍ 01-) ) ⟧, λ ⤍ Package ⟧, λ ⤍ Package ⟧⟧ }" +-- Right (ProgramMetrics {bindingsByPathMetrics = Just (BindingsByPathMetrics {path = ["org","eolang"], bindingsMetrics = [BindingMetrics {name = "x", metrics = Metrics {dataless = 0, applications = 2, formations = 1, dispatches = 6}},BindingMetrics {name = "z", metrics = Metrics {dataless = 0, applications = 2, formations = 2, dispatches = 7}}]}), programMetrics = Metrics {dataless = 0, applications = 4, formations = 6, dispatches = 13}}) +-- +-- >>> flip getProgramMetrics (Just ["a"]) "{⟦ a ↦ ⟦ b ↦ ⟦ c ↦ ∅, d ↦ ⟦ φ ↦ ξ.ρ.c ⟧ ⟧, e ↦ ξ.b(c ↦ ⟦⟧).d ⟧.e ⟧}" +-- Left ["a"] +-- +-- >>> flip getProgramMetrics (Just ["a"]) "{⟦ a ↦ ⟦ b ↦ ⟦ c ↦ ∅, d ↦ ⟦ φ ↦ ξ.ρ.c ⟧ ⟧, e ↦ ξ.b(c ↦ ⟦⟧).d ⟧ ⟧}" +-- Right (ProgramMetrics {bindingsByPathMetrics = Just (BindingsByPathMetrics {path = ["a"], bindingsMetrics = [BindingMetrics {name = "b", metrics = Metrics {dataless = 0, applications = 0, formations = 2, dispatches = 2}},BindingMetrics {name = "e", metrics = Metrics {dataless = 1, applications = 1, formations = 1, dispatches = 2}}]}), programMetrics = Metrics {dataless = 1, applications = 1, formations = 5, dispatches = 4}}) +getProgramMetrics :: Program -> Maybe Path -> Either Path ProgramMetrics +getProgramMetrics (Program bindings) path = do + ObjectMetrics{..} <- getObjectMetrics (Formation bindings) path + pure ProgramMetrics{programMetrics = thisObjectMetrics, ..} diff --git a/src/Language/EO/Phi/Metrics/Data.hs b/src/Language/EO/Phi/Metrics/Data.hs new file mode 100644 --- /dev/null +++ b/src/Language/EO/Phi/Metrics/Data.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Language.EO.Phi.Metrics.Data where + +import Data.Aeson (ToJSON (..), Value (..), withObject, withScientific, withText, (.:), (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Types (FromJSON (..), Parser, parseFail) +import Data.Generics.Labels () +import Data.List (groupBy, intercalate) +import Data.Scientific (toRealFloat) +import GHC.Generics (Generic) +import Language.EO.Phi.Rules.Common () +import Language.EO.Phi.TH (deriveJSON) + +data Metrics a = Metrics + { formations :: a + , dataless :: a + , applications :: a + , dispatches :: a + } + deriving stock (Show, Generic, Eq, Functor, Foldable, Traversable) + +$(deriveJSON ''Metrics) + +toListMetrics :: Metrics a -> [a] +toListMetrics = foldMap (: []) + +instance Applicative Metrics where + pure :: a -> Metrics a + pure a = + Metrics + { formations = a + , dataless = a + , applications = a + , dispatches = a + } + + (<*>) :: Metrics (a -> b) -> Metrics a -> Metrics b + x <*> y = + Metrics + { formations = x.formations y.formations + , dataless = x.dataless y.dataless + , applications = x.applications y.applications + , dispatches = x.dispatches y.dispatches + } + +instance (Num a) => Num (Metrics a) where + (+) :: Metrics a -> Metrics a -> Metrics a + (+) x y = (+) <$> x <*> y + (-) :: Metrics a -> Metrics a -> Metrics a + (-) x y = (-) <$> x <*> y + (*) :: Metrics a -> Metrics a -> Metrics a + (*) x y = (*) <$> x <*> y + negate :: Metrics a -> Metrics a + negate = (negate <$>) + abs :: Metrics a -> Metrics a + abs = (abs <$>) + signum :: Metrics a -> Metrics a + signum = (signum <$>) + fromInteger :: Integer -> Metrics a + fromInteger x = pure $ fromInteger x + +data SafeNumber a = SafeNumber'NaN | SafeNumber'Number a + deriving stock (Functor) + +-- >>> import Data.Aeson (decode') +-- +-- >>> decode' @(SafeNumber Double) "\"NaN\"" +-- Just NaN +-- +-- >>> decode' @(SafeNumber Double) "3" +-- Just 3.0 + +instance (FromJSON a, RealFloat a) => FromJSON (SafeNumber a) where + parseJSON :: Value -> Parser (SafeNumber a) + parseJSON (String s) = + withText + "NaN" + ( \case + "NaN" -> pure SafeNumber'NaN + _ -> parseFail "String is not a NaN" + ) + (String s) + parseJSON (Number n) = + withScientific + "Number" + (pure . pure . toRealFloat) + (Number n) + parseJSON _ = parseFail "Value is not a NaN or a Number" + +instance (ToJSON a) => ToJSON (SafeNumber a) where + toJSON :: SafeNumber a -> Value + toJSON (SafeNumber'Number a) = toJSON a + toJSON SafeNumber'NaN = toJSON ("NaN" :: String) + +instance (Show a) => Show (SafeNumber a) where + show :: SafeNumber a -> String + show (SafeNumber'Number a) = show a + show SafeNumber'NaN = "NaN" + +instance (Eq a) => Eq (SafeNumber a) where + (==) :: SafeNumber a -> SafeNumber a -> Bool + (==) (SafeNumber'Number x) (SafeNumber'Number y) = x == y + (==) _ _ = False + +instance (Ord a) => Ord (SafeNumber a) where + (<=) :: SafeNumber a -> SafeNumber a -> Bool + (SafeNumber'Number x) <= (SafeNumber'Number y) = x <= y + _ <= SafeNumber'Number _ = True + _ <= _ = False + +instance Applicative SafeNumber where + pure :: a -> SafeNumber a + pure = SafeNumber'Number + (<*>) :: SafeNumber (a -> b) -> SafeNumber a -> SafeNumber b + (<*>) (SafeNumber'Number x') (SafeNumber'Number y') = SafeNumber'Number (x' y') + (<*>) _ _ = SafeNumber'NaN + +instance (Num a) => Num (SafeNumber a) where + (+) :: SafeNumber a -> SafeNumber a -> SafeNumber a + (+) x y = (+) <$> x <*> y + (*) :: SafeNumber a -> SafeNumber a -> SafeNumber a + (*) x y = (*) <$> x <*> y + abs :: SafeNumber a -> SafeNumber a + abs = (abs <$>) + signum :: SafeNumber a -> SafeNumber a + signum = (signum <$>) + fromInteger :: Integer -> SafeNumber a + fromInteger x = pure $ fromInteger x + negate :: SafeNumber a -> SafeNumber a + negate = (negate <$>) + +instance (Fractional a, Eq a) => Fractional (SafeNumber a) where + fromRational :: Rational -> SafeNumber a + fromRational = SafeNumber'Number . fromRational + (/) :: SafeNumber a -> SafeNumber a -> SafeNumber a + (/) (SafeNumber'Number x) (SafeNumber'Number y) | y /= 0 = SafeNumber'Number (x / y) + (/) _ _ = SafeNumber'NaN + +type MetricsSafe a = Metrics (SafeNumber a) + +instance (Fractional a, Eq a) => Fractional (MetricsSafe a) where + fromRational :: Rational -> MetricsSafe a + fromRational _ = 0 + (/) :: MetricsSafe a -> MetricsSafe a -> MetricsSafe a + (/) x y = (/) <$> x <*> y + +instance (Num a) => Semigroup (Metrics a) where + (<>) :: Metrics a -> Metrics a -> Metrics a + (<>) = (+) + +instance (Num a) => Monoid (Metrics a) where + mempty :: Metrics a + mempty = 0 + +type MetricsCount = Metrics Int + +data BindingMetrics = BindingMetrics + { name :: String + , metrics :: MetricsCount + } + deriving stock (Show, Generic, Eq) + +$(deriveJSON ''BindingMetrics) + +type Path = [String] + +data BindingsByPathMetrics = BindingsByPathMetrics + { path :: Path + , bindingsMetrics :: [BindingMetrics] + } + deriving (Show, Generic, Eq) + +-- >>> splitStringOn '.' "abra.cada.bra" +-- ["abra","cada","bra"] +-- +-- >>> splitStringOn '.' "" +-- [] +splitStringOn :: Char -> String -> Path +splitStringOn sep = filter (/= [sep]) . groupBy (\a b -> a /= sep && b /= sep) + +splitPath :: String -> Path +splitPath = splitStringOn '.' + +instance FromJSON BindingsByPathMetrics where + parseJSON :: Value -> Parser BindingsByPathMetrics + parseJSON = withObject "BindingsByPathMetrics" $ \obj -> do + path <- splitPath <$> (obj .: "path") + bindingsMetrics <- obj .: "bindings-metrics" + pure BindingsByPathMetrics{..} + +instance ToJSON BindingsByPathMetrics where + toJSON :: BindingsByPathMetrics -> Value + toJSON BindingsByPathMetrics{..} = + Aeson.object + [ "path" .= intercalate "." path + , "bindings-metrics" .= bindingsMetrics + ] + +data ObjectMetrics = ObjectMetrics + { bindingsByPathMetrics :: Maybe BindingsByPathMetrics + , thisObjectMetrics :: MetricsCount + } + deriving (Show, Generic, Eq) + +$(deriveJSON ''ObjectMetrics) + +data ProgramMetrics = ProgramMetrics + { bindingsByPathMetrics :: Maybe BindingsByPathMetrics + , programMetrics :: MetricsCount + } + deriving (Show, Generic, Eq) + +$(deriveJSON ''ProgramMetrics) diff --git a/src/Language/EO/Phi/Normalize.hs b/src/Language/EO/Phi/Normalize.hs --- a/src/Language/EO/Phi/Normalize.hs +++ b/src/Language/EO/Phi/Normalize.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} module Language.EO.Phi.Normalize ( normalizeObject, @@ -10,15 +12,19 @@ import Control.Monad.State import Data.Maybe (fromMaybe) +import Control.Lens.Setter ((+=)) import Control.Monad (forM) -import Language.EO.Phi.Rules.Common (intToBytesObject, lookupBinding, nuCount, objectBindings) +import Data.Generics.Labels () +import GHC.Generics (Generic) +import Language.EO.Phi.Rules.Common (getMaxNu, intToBytesObject, lookupBinding, objectBindings) import Language.EO.Phi.Syntax.Abs data Context = Context { globalObject :: [Binding] , thisObject :: [Binding] - , totalNuCount :: Int + , maxNu :: Int } + deriving (Generic) isNu :: Binding -> Bool isNu (AlphaBinding VTX _) = True @@ -33,7 +39,7 @@ Context { globalObject = bindings , thisObject = bindings - , totalNuCount = nuCount (Formation bindings) + , maxNu = getMaxNu (Formation bindings) } rule1 :: Object -> State Context Object @@ -48,8 +54,8 @@ finalBindings <- if not $ any isNu normalizedBindings then do - nus <- gets totalNuCount - modify (\c -> c{totalNuCount = totalNuCount c + 1}) + #maxNu += 1 + nus <- gets maxNu let dataObject = intToBytesObject nus pure (AlphaBinding VTX dataObject : normalizedBindings) else do diff --git a/src/Language/EO/Phi/Report/Data.hs b/src/Language/EO/Phi/Report/Data.hs new file mode 100644 --- /dev/null +++ b/src/Language/EO/Phi/Report/Data.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-partial-fields #-} + +module Language.EO.Phi.Report.Data where + +import GHC.Generics (Generic) +import Language.EO.Phi.Metrics.Data (BindingMetrics (..), Metrics (..), MetricsCount, ProgramMetrics, SafeNumber (..)) +import Language.EO.Phi.Metrics.Data qualified as Metrics +import Language.EO.Phi.TH (deriveJSON) +import Prelude hiding (div, id, span) + +data ReportItem = ReportItem + { phi :: FilePath + , phiNormalized :: FilePath + , bindingsPathPhi :: Maybe String + , bindingsPathPhiNormalized :: Maybe String + } + deriving stock (Show, Generic) + +$(deriveJSON ''ReportItem) + +data MetricsChangeCategory a + = MetricsChange'Good {change :: a} + | MetricsChange'Bad {change :: a} + | MetricsChange'NA + deriving stock (Show, Generic, Eq) + +$(deriveJSON ''MetricsChangeCategory) + +type MetricsChange = Metrics (SafeNumber Double) + +newtype Percent = Percent {percent :: Double} + +$(deriveJSON ''Percent) + +type MetricsChangeCategorized = Metrics (MetricsChangeCategory Percent) + +data Report'InputConfig = Report'InputConfig + { js :: Maybe FilePath + , css :: Maybe FilePath + } + deriving stock (Show, Generic) + +$(deriveJSON ''Report'InputConfig) + +data Report'OutputConfig = Report'OutputConfig + { html :: Maybe FilePath + , json :: Maybe FilePath + , markdown :: Maybe FilePath + } + deriving stock (Show, Generic) + +$(deriveJSON ''Report'OutputConfig) + +data ReportConfig = ReportConfig + { input :: Maybe Report'InputConfig + , output :: Report'OutputConfig + , expectedMetricsChange :: MetricsChange + , items :: [ReportItem] + } + deriving stock (Show, Generic) + +$(deriveJSON ''ReportConfig) + +data ReportRow = ReportRow + { fileInitial :: Maybe FilePath + , fileNormalized :: Maybe FilePath + , bindingsPathInitial :: Maybe Metrics.Path + , bindingsPathNormalized :: Maybe Metrics.Path + , attributeInitial :: Maybe String + , attributeNormalized :: Maybe String + , metricsChange :: MetricsChangeCategorized + , metricsInitial :: Metrics Int + , metricsNormalized :: Metrics Int + } + +$(deriveJSON ''ReportRow) + +data ProgramReport = ProgramReport + { programRow :: ReportRow + , bindingsRows :: [ReportRow] + } + +$(deriveJSON ''ProgramReport) + +data Report = Report + { totalRow :: ReportRow + , programReports :: [ProgramReport] + } + +$(deriveJSON ''Report) + +calculateMetricsChange :: MetricsChange -> MetricsCount -> MetricsCount -> MetricsChangeCategorized +calculateMetricsChange expectedMetricsChange countInitial countNormalized = + getMetricsChangeClassified <$> expectedMetricsChange <*> actualMetricsChange + where + getMetricsChangeClassified (SafeNumber'Number expected) (SafeNumber'Number actual) + | actual >= expected = MetricsChange'Good (Percent actual) + | otherwise = MetricsChange'Bad (Percent actual) + getMetricsChangeClassified _ _ = MetricsChange'NA + actualMetricsChange :: MetricsChange + actualMetricsChange = (initial - normalized) / initial + initial = fromIntegral <$> countInitial + normalized = fromIntegral <$> countNormalized + +makeProgramReport :: ReportConfig -> ReportItem -> ProgramMetrics -> ProgramMetrics -> ProgramReport +makeProgramReport reportConfig reportItem metricsPhi metricsPhiNormalized = + ProgramReport{..} + where + bindingsRows = + case (metricsPhi.bindingsByPathMetrics, metricsPhiNormalized.bindingsByPathMetrics) of + (Just bindingsMetricsNormalized, Just bindingsMetricsInitial) -> + [ ReportRow + { fileInitial = Just reportItem.phi + , fileNormalized = Just reportItem.phiNormalized + , bindingsPathInitial = Just bindingsMetricsNormalized.path + , bindingsPathNormalized = Just bindingsMetricsNormalized.path + , attributeInitial = Just attributeInitial + , attributeNormalized = Just attributeNormalized + , metricsChange = calculateMetricsChange reportConfig.expectedMetricsChange metricsInitial metricsNormalized + , metricsInitial = metricsInitial + , metricsNormalized = metricsNormalized + } + | BindingMetrics{name = attributeInitial, metrics = metricsInitial} <- bindingsMetricsInitial.bindingsMetrics + | BindingMetrics{name = attributeNormalized, metrics = metricsNormalized} <- bindingsMetricsNormalized.bindingsMetrics + ] + _ -> [] + programRow = + ReportRow + { fileInitial = Just reportItem.phi + , fileNormalized = Just reportItem.phiNormalized + , bindingsPathInitial = Nothing + , bindingsPathNormalized = Nothing + , attributeInitial = Nothing + , attributeNormalized = Nothing + , metricsChange = calculateMetricsChange reportConfig.expectedMetricsChange metricsPhi.programMetrics metricsPhiNormalized.programMetrics + , metricsInitial = metricsPhi.programMetrics + , metricsNormalized = metricsPhiNormalized.programMetrics + } + +makeReport :: ReportConfig -> [ProgramReport] -> Report +makeReport reportConfig programReports = + Report{..} + where + programRows = (.programRow) <$> programReports + metricsInitial = foldMap (.metricsInitial) programRows + metricsNormalized = foldMap (.metricsNormalized) programRows + metricsChange = calculateMetricsChange reportConfig.expectedMetricsChange metricsInitial metricsNormalized + totalRow = + ReportRow + { fileInitial = Nothing + , fileNormalized = Nothing + , bindingsPathInitial = Nothing + , bindingsPathNormalized = Nothing + , attributeInitial = Nothing + , attributeNormalized = Nothing + , .. + } diff --git a/src/Language/EO/Phi/Report/Html.hs b/src/Language/EO/Phi/Report/Html.hs new file mode 100644 --- /dev/null +++ b/src/Language/EO/Phi/Report/Html.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-partial-fields #-} + +module Language.EO.Phi.Report.Html where + +import Data.FileEmbed (embedFileRelative) +import Data.List (intercalate) +import Data.Maybe (fromMaybe) +import Data.String.Interpolate +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Language.EO.Phi.Metrics.Data (Metrics (..), MetricsCount, SafeNumber (..), toListMetrics) +import Language.EO.Phi.Report.Data (MetricsChange, MetricsChangeCategorized, MetricsChangeCategory (..), Percent (..), ProgramReport (..), Report (..), ReportRow (..)) +import Text.Blaze.Html.Renderer.String (renderHtml) +import Text.Blaze.Html5 hiding (i) +import Text.Blaze.Html5.Attributes (class_, colspan, id, onclick, type_, value) +import Text.Printf (printf) +import Prelude hiding (div, id, span) + +-- | JavaScript file to embed into HTML reports +reportJS :: String +reportJS = T.unpack $ T.decodeUtf8 $(embedFileRelative "report/main.js") + +-- | CSS file to embed into HTML reports +reportCSS :: String +reportCSS = T.unpack $ T.decodeUtf8 $(embedFileRelative "report/styles.css") + +metricsNames :: Metrics String +metricsNames = + Metrics + { dataless = "Dataless formations" + , applications = "Applications" + , formations = "Formations" + , dispatches = "Dispatches" + } + +toHtmlReportHeader :: Html +toHtmlReportHeader = + thead $ + toHtml + [ tr $ + toHtml + [ th ! colspan "2" ! class_ "no-sort" $ "Attribute" + , th ! colspan "4" ! class_ "no-sort" $ "Improvement = (Initial - Normalized) / Initial" + , th ! colspan "4" ! class_ "no-sort" $ "Initial" + , th ! colspan "4" ! class_ "no-sort" $ "Normalized" + , th ! colspan "4" ! class_ "no-sort" $ "Location" + ] + , tr . toHtml $ + th + <$> [ "Attribute Initial" + , "Attribute Normalized" + ] + <> ( concat + . replicate 3 + . (toHtml <$>) + $ toListMetrics metricsNames + ) + <> [ "File Initial" + , "Bindings Path Initial" + , "File Normalized" + , "Bindings Path Normalized" + ] + ] + +data ReportFormat + = ReportFormat'Html + { css :: String + , js :: String + } + | -- | GitHub Flavored Markdown + ReportFormat'Markdown + deriving stock (Eq) + +data ReportConfig = ReportConfig + { expectedMetricsChange :: MetricsChange + , format :: ReportFormat + } + +instance (ToMarkup a) => ToMarkup (SafeNumber a) where + toMarkup :: SafeNumber a -> Markup + toMarkup (SafeNumber'Number n) = toMarkup n + toMarkup SafeNumber'NaN = toMarkup ("NaN" :: String) + +roundToStr :: Int -> Double -> String +roundToStr = printf "%0.*f%%" + +instance ToMarkup Percent where + toMarkup :: Percent -> Markup + toMarkup Percent{..} = toMarkup $ roundToStr 2 (percent * 100) + +-- >>> import Text.Blaze.Html.Renderer.String (renderHtml) +-- >>> reportConfig = ReportConfig { expectedMetricsChange = 0, format = ReportFormat'Markdown } +-- +-- >>> renderHtml $ toHtmlChange reportConfig (MetricsChange'Bad 0.2) +-- "0.2\128308" +-- +-- >>> renderHtml $ toHtmlChange reportConfig (MetricsChange'Good 0.5) +-- "0.5\128994" +-- >>> renderHtml $ toHtmlChange reportConfig (MetricsChange'NA :: MetricsChangeCategory Double) +-- "N/A\128995" +toHtmlChange :: (ToMarkup a) => ReportConfig -> MetricsChangeCategory a -> Html +toHtmlChange reportConfig = \case + MetricsChange'NA -> td ! class_ "number not-applicable" $ toHtml ("N/A" :: String) <> toHtml ['🟣' | isMarkdown] + MetricsChange'Bad{..} -> td ! class_ "number bad" $ toHtml change <> toHtml ['🔴' | isMarkdown] + MetricsChange'Good{..} -> td ! class_ "number good" $ toHtml change <> toHtml ['🟢' | isMarkdown] + where + isMarkdown = reportConfig.format == ReportFormat'Markdown + +toHtmlMetricsChange :: ReportConfig -> MetricsChangeCategorized -> [Html] +toHtmlMetricsChange reportConfig change = toHtmlChange reportConfig <$> toListMetrics change + +toHtmlMetrics :: MetricsCount -> [Html] +toHtmlMetrics metrics = + (td ! class_ "number") + . toHtml + <$> toListMetrics metrics + +toHtmlReportRow :: ReportConfig -> ReportRow -> Html +toHtmlReportRow reportConfig reportRow = + tr . toHtml $ + ( td + . toHtml + <$> [ fromMaybe "[N/A]" reportRow.attributeInitial + , fromMaybe "[N/A]" reportRow.attributeNormalized + ] + ) + <> toHtmlMetricsChange reportConfig reportRow.metricsChange + <> toHtmlMetrics reportRow.metricsInitial + <> toHtmlMetrics reportRow.metricsNormalized + <> ( td + . toHtml + <$> [ fromMaybe "[all programs]" reportRow.fileInitial + , intercalate "." $ fromMaybe ["[whole program]"] reportRow.bindingsPathInitial + , fromMaybe "[all programs]" reportRow.fileNormalized + , intercalate "." $ fromMaybe ["[whole program]"] reportRow.bindingsPathNormalized + ] + ) + +-- | Number of tests where metrics changes were better than expected +countGoodMetricsChanges :: Report -> MetricsCount +countGoodMetricsChanges report = metricsCount + where + metricsChanges = (.metricsChange) <$> concatMap (.bindingsRows) report.programReports + metricsCount = foldMap ((\case MetricsChange'Good _ -> 1; _ -> 0) <$>) metricsChanges + +-- | Number of tests in all programs +countTests :: Report -> Int +countTests report = length $ concatMap (.bindingsRows) report.programReports + +toHtmlReport :: ReportConfig -> Report -> Html +toHtmlReport reportConfig report = + toHtml $ + [ h2 "Overview" + <> p + [i| + We translate EO files into PHI programs. + Next, we normalize these programs. + Then, we collect metrics for initial and normalized PHI programs. + |] + <> p + [i| + An EO file contains multiple test objects. + After conversion, these test objects become attributes in PHI programs. + We call these attributes "tests". + |] + <> p + [i| + In the report below, we present combined metrics for all programs, + metrics for programs, + and metrics for tests. + |] + <> h2 "Metrics" + <> p + [i| + We collect metrics on the number of dataless formations, applications, formations, and dispatches. + We want normalized PHI programs to have a smaller number of such elements than initial PHI programs. + |] + <> p [i|These numbers are expected to reduce as follows:|] + <> ul + ( toHtml . toListMetrics $ + makeMetricsItem + <$> metricsNames + <*> ((Percent <$>) <$> reportConfig.expectedMetricsChange) + ) + <> h2 "Statistics" + <> p [i|Total number of tests: #{countTests report}.|] + <> p + [i| + For each metric, the number of tests where the metric was reduced as expected + (not counting tests where the metric was initially 0): + |] + <> ul + ( toHtml . toListMetrics $ + makeMetricsItem + <$> metricsNames + <*> countGoodMetricsChanges report + ) + <> h2 "Detailed results" + ] + <> [ + -- https://stackoverflow.com/a/55743302 + -- https://stackoverflow.com/a/3169849 + ( script ! type_ "text/javascript" $ + [i| + function copytable(el) { + var urlField = document.getElementById(el) + var range = document.createRange() + range.selectNode(urlField) + window.getSelection().addRange(range) + document.execCommand('copy') + + if (window.getSelection().empty) { // Chrome + window.getSelection().empty(); + } else if (window.getSelection().removeAllRanges) { // Firefox + window.getSelection().removeAllRanges(); + } + } + |] + ) + <> (input ! type_ "button" ! value "Copy to Clipboard" ! onclick "copytable('table')") + <> h3 "Columns" + <> p "Columns in this table are sortable." + <> p "Hover over a header cell from the second row of header cells (Attribute Initial, etc.) to see a triangle demonstrating the sorting order." + <> ul + ( toHtml + [ li "▾: descending" + , li "▴: ascending" + , li "▸: unordered" + ] + ) + <> p "Click on the triangle to change the sorting order in the corresponding column." + | not isMarkdown + ] + <> [ table ! class_ "sortable" ! id "table" $ + toHtml + [ toHtmlReportHeader + , tbody . toHtml $ + toHtmlReportRow reportConfig + <$> ( report.totalRow + : concat + [ programReport.programRow : programReport.bindingsRows + | programReport <- report.programReports + ] + ) + ] + ] + <> ( case reportConfig.format of + ReportFormat'Html{..} -> + [ style ! type_ "text/css" $ toHtml css + , script $ toHtml js + ] + ReportFormat'Markdown -> [] + ) + where + isMarkdown = reportConfig.format == ReportFormat'Markdown + makeMetricsItem :: (ToMarkup a) => String -> a -> Html + makeMetricsItem name x = li $ b (toHtml ([i|#{name}: |] :: String)) <> toHtml x + +toStringReport :: ReportConfig -> Report -> String +toStringReport reportConfig report = renderHtml $ toHtmlReport reportConfig report diff --git a/src/Language/EO/Phi/Rules/Common.hs b/src/Language/EO/Phi/Rules/Common.hs --- a/src/Language/EO/Phi/Rules/Common.hs +++ b/src/Language/EO/Phi/Rules/Common.hs @@ -1,16 +1,21 @@ +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} module Language.EO.Phi.Rules.Common where import Control.Applicative (Alternative ((<|>)), asum) +import Data.List (nubBy, sortOn) import Data.List.NonEmpty (NonEmpty (..), (<|)) +import Data.List.NonEmpty qualified as NonEmpty import Data.String (IsString (..)) import Language.EO.Phi.Syntax.Abs import Language.EO.Phi.Syntax.Lex (Token) import Language.EO.Phi.Syntax.Par -import Numeric (showHex) +import Numeric (readHex, showHex) -- $setup -- >>> :set -XOverloadedStrings @@ -38,20 +43,36 @@ Left parseError -> error parseError Right object -> object +type NamedRule = (String, Rule) + data Context = Context - { allRules :: [Rule] + { allRules :: [NamedRule] , outerFormations :: NonEmpty Object + , currentAttr :: Attribute + , insideFormation :: Bool + -- ^ Temporary hack for applying Ksi and Phi rules when dataizing } +defaultContext :: [NamedRule] -> Object -> Context +defaultContext rules obj = + Context + { allRules = rules + , outerFormations = NonEmpty.singleton obj + , currentAttr = Sigma + , insideFormation = False + } + -- | A rule tries to apply a transformation to the root object, if possible. type Rule = Context -> Object -> [Object] -applyOneRuleAtRoot :: Context -> Object -> [Object] +applyOneRuleAtRoot :: Context -> Object -> [(String, Object)] applyOneRuleAtRoot ctx@Context{..} obj = - [ obj' - | rule <- allRules - , obj' <- rule ctx obj - ] + nubBy + equalObjectNamed + [ (ruleName, obj') + | (ruleName, rule) <- allRules + , obj' <- rule ctx obj + ] extendContextWith :: Object -> Context -> Context extendContextWith obj ctx = @@ -59,41 +80,53 @@ { outerFormations = obj <| outerFormations ctx } -withSubObject :: (Context -> Object -> [Object]) -> Context -> Object -> [Object] +withSubObject :: (Context -> Object -> [(String, Object)]) -> Context -> Object -> [(String, Object)] withSubObject f ctx root = f ctx root <|> case root of Formation bindings -> - Formation <$> withSubObjectBindings f (extendContextWith root ctx) bindings + propagateName1 Formation <$> withSubObjectBindings f ((extendContextWith root ctx){insideFormation = True}) bindings Application obj bindings -> asum - [ Application <$> withSubObject f ctx obj <*> pure bindings - , Application obj <$> withSubObjectBindings f ctx bindings + [ propagateName2 Application <$> withSubObject f ctx obj <*> pure bindings + , propagateName1 (Application obj) <$> withSubObjectBindings f ctx bindings ] - ObjectDispatch obj a -> ObjectDispatch <$> withSubObject f ctx obj <*> pure a + ObjectDispatch obj a -> propagateName2 ObjectDispatch <$> withSubObject f ctx obj <*> pure a GlobalObject{} -> [] ThisObject{} -> [] Termination -> [] MetaObject _ -> [] MetaFunction _ _ -> [] -withSubObjectBindings :: (Context -> Object -> [Object]) -> Context -> [Binding] -> [[Binding]] +-- | Given a unary function that operates only on plain objects, +-- converts it to a function that operates on name objects +propagateName1 :: (a -> b) -> (name, a) -> (name, b) +propagateName1 f (name, obj) = (name, f obj) + +-- | Given a binary function that operates only on plain objects, +-- converts it to a function that operates on name objects +propagateName2 :: (a -> b -> c) -> (name, a) -> b -> (name, c) +propagateName2 f (name, obj) bs = (name, f obj bs) + +withSubObjectBindings :: (Context -> Object -> [(String, Object)]) -> Context -> [Binding] -> [(String, [Binding])] withSubObjectBindings _ _ [] = [] withSubObjectBindings f ctx (b : bs) = asum - [ [b' : bs | b' <- withSubObjectBinding f ctx b] - , [b : bs' | bs' <- withSubObjectBindings f ctx bs] + [ [(name, b' : bs) | (name, b') <- withSubObjectBinding f ctx b] + , [(name, b : bs') | (name, bs') <- withSubObjectBindings f ctx bs] ] -withSubObjectBinding :: (Context -> Object -> [Object]) -> Context -> Binding -> [Binding] +withSubObjectBinding :: (Context -> Object -> [(String, Object)]) -> Context -> Binding -> [(String, Binding)] withSubObjectBinding f ctx = \case - AlphaBinding a obj -> AlphaBinding a <$> withSubObject f ctx obj + AlphaBinding a obj -> propagateName1 (AlphaBinding a) <$> withSubObject f (ctx{currentAttr = a}) obj EmptyBinding{} -> [] DeltaBinding{} -> [] + DeltaEmptyBinding{} -> [] + MetaDeltaBinding{} -> [] LambdaBinding{} -> [] MetaBindings _ -> [] -applyOneRule :: Context -> Object -> [Object] +applyOneRule :: Context -> Object -> [(String, Object)] applyOneRule = withSubObject applyOneRuleAtRoot isNF :: Context -> Object -> Bool @@ -103,21 +136,103 @@ -- -- >>> mapM_ (putStrLn . Language.EO.Phi.printTree) (applyRules (Context [rule6] ["⟦ a ↦ ⟦ b ↦ ⟦ ⟧ ⟧.b ⟧"]) "⟦ a ↦ ⟦ b ↦ ⟦ ⟧ ⟧.b ⟧.a") applyRules :: Context -> Object -> [Object] -applyRules ctx obj +applyRules ctx obj = applyRulesWith (defaultApplicationLimits (objectSize obj)) ctx obj + +data ApplicationLimits = ApplicationLimits + { maxDepth :: Int + , maxTermSize :: Int + } + +defaultApplicationLimits :: Int -> ApplicationLimits +defaultApplicationLimits sourceTermSize = + ApplicationLimits + { maxDepth = 13 + , maxTermSize = sourceTermSize * 10 + } + +objectSize :: Object -> Int +objectSize = \case + Formation bindings -> 1 + sum (map bindingSize bindings) + Application obj bindings -> 1 + objectSize obj + sum (map bindingSize bindings) + ObjectDispatch obj _attr -> 1 + objectSize obj + GlobalObject -> 1 + ThisObject -> 1 + Termination -> 1 + MetaObject{} -> 1 -- should be impossible + MetaFunction{} -> 1 -- should be impossible + +bindingSize :: Binding -> Int +bindingSize = \case + AlphaBinding _attr obj -> objectSize obj + EmptyBinding _attr -> 1 + DeltaBinding _bytes -> 1 + DeltaEmptyBinding -> 1 + LambdaBinding _lam -> 1 + MetaDeltaBinding{} -> 1 -- should be impossible + MetaBindings{} -> 1 -- should be impossible + +-- | A variant of `applyRules` with a maximum application depth. +applyRulesWith :: ApplicationLimits -> Context -> Object -> [Object] +applyRulesWith limits@ApplicationLimits{..} ctx obj + | maxDepth <= 0 = [obj] | isNF ctx obj = [obj] | otherwise = - [ obj'' - | obj' <- applyOneRule ctx obj - , obj'' <- applyRules ctx obj' - ] + nubBy + equalObject + [ obj'' + | (_ruleName, obj') <- applyOneRule ctx obj + , objectSize obj' < maxTermSize + , obj'' <- applyRulesWith limits{maxDepth = maxDepth - 1} ctx obj' + ] -applyRulesChain :: Context -> Object -> [[Object]] -applyRulesChain ctx obj - | isNF ctx obj = [[obj]] +equalProgram :: Program -> Program -> Bool +equalProgram (Program bindings1) (Program bindings2) = equalObject (Formation bindings1) (Formation bindings2) + +equalObject :: Object -> Object -> Bool +equalObject (Formation bindings1) (Formation bindings2) = + length bindings1 == length bindings2 && equalBindings bindings1 bindings2 +equalObject (Application obj1 bindings1) (Application obj2 bindings2) = + equalObject obj1 obj2 && equalBindings bindings1 bindings2 +equalObject (ObjectDispatch obj1 attr1) (ObjectDispatch obj2 attr2) = + equalObject obj1 obj2 && attr1 == attr2 +equalObject obj1 obj2 = obj1 == obj2 + +equalObjectNamed :: (String, Object) -> (String, Object) -> Bool +equalObjectNamed x y = snd x `equalObject` snd y + +equalBindings :: [Binding] -> [Binding] -> Bool +equalBindings bindings1 bindings2 = and (zipWith equalBinding (sortOn attr bindings1) (sortOn attr bindings2)) + where + attr (AlphaBinding a _) = a + attr (EmptyBinding a) = a + attr (DeltaBinding _) = Label (LabelId "Δ") + attr DeltaEmptyBinding = Label (LabelId "Δ") + attr (MetaDeltaBinding _) = Label (LabelId "Δ") + attr (LambdaBinding _) = Label (LabelId "λ") + attr (MetaBindings metaId) = MetaAttr metaId + +equalBinding :: Binding -> Binding -> Bool +equalBinding (AlphaBinding VTX _) (AlphaBinding VTX _) = True -- TODO #166:15min Renumerate vertices uniformly instead of ignoring them +equalBinding (AlphaBinding attr1 obj1) (AlphaBinding attr2 obj2) = attr1 == attr2 && equalObject obj1 obj2 +-- Ignore deltas for now while comparing since different normalization paths can lead to different vertex data +-- TODO #120:30m normalize the deltas instead of ignoring since this actually suppresses problems +equalBinding (DeltaBinding _) (DeltaBinding _) = True +equalBinding b1 b2 = b1 == b2 + +-- | Apply the rules until the object is normalized, preserving the history (chain) of applications. +applyRulesChain :: Context -> Object -> [[(String, Object)]] +applyRulesChain ctx obj = applyRulesChainWith (defaultApplicationLimits (objectSize obj)) ctx obj + +-- | A variant of `applyRulesChain` with a maximum application depth. +applyRulesChainWith :: ApplicationLimits -> Context -> Object -> [[(String, Object)]] +applyRulesChainWith limits@ApplicationLimits{..} ctx obj + | maxDepth <= 0 = [[("Max depth hit", obj)]] + | isNF ctx obj = [[("Normal form", obj)]] | otherwise = - [ obj : chain - | obj' <- applyOneRule ctx obj - , chain <- applyRulesChain ctx obj' + [ (ruleName, obj) : chain + | (ruleName, obj') <- applyOneRule ctx obj + , objectSize obj' < maxTermSize + , chain <- applyRulesChainWith limits{maxDepth = maxDepth - 1} ctx obj' ] -- * Helpers @@ -136,18 +251,8 @@ objectBindings (ObjectDispatch obj _attr) = objectBindings obj objectBindings _ = [] -nuCount :: Object -> Int -nuCount obj = count isNu (objectBindings obj) + sum (map (sum . map nuCount . values) (objectBindings obj)) - where - isNu (AlphaBinding VTX _) = True - isNu (EmptyBinding VTX) = True - isNu _ = False - count = (length .) . filter - values (AlphaBinding _ obj') = [obj'] - values _ = [] - -intToBytesObject :: Int -> Object -intToBytesObject n = Formation [DeltaBinding $ Bytes $ insertDashes $ pad $ showHex n ""] +intToBytes :: Int -> Bytes +intToBytes n = Bytes $ insertDashes $ pad $ showHex n "" where pad s = (if even (length s) then "" else "0") ++ s insertDashes s @@ -160,5 +265,46 @@ (x : y : xs) -> x : y : '-' : go xs in go s +-- | Assuming the bytes are well-formed (otherwise crashes) +bytesToInt :: Bytes -> Int +bytesToInt (Bytes (filter (/= '-') . dropWhile (== '0') -> bytes)) + | null bytes = 0 + | otherwise = fst $ head $ readHex bytes + +minNu :: Int +minNu = -1 + +class HasMaxNu a where + -- | get maximum vertex index + -- + -- >>> getMaxNu @Object "⟦ a ↦ ⟦ ν ↦ ⟦ Δ ⤍ 03- ⟧ ⟧, b ↦ ⟦ ⟧ ⟧" + -- 3 + getMaxNu :: a -> Int + +instance HasMaxNu Program where + getMaxNu :: Program -> Int + getMaxNu (Program bindings) = getMaxNu (Formation bindings) + +instance HasMaxNu Object where + getMaxNu :: Object -> Int + getMaxNu = \case + Formation bindings -> maximum (minNu : (getMaxNu <$> bindings)) + Application obj bindings -> maximum (minNu : getMaxNu obj : (getMaxNu <$> bindings)) + ObjectDispatch obj _ -> getMaxNu obj + _ -> minNu + +instance HasMaxNu Binding where + getMaxNu :: Binding -> Int + getMaxNu = \case + AlphaBinding VTX (Formation [DeltaBinding (Bytes bs)]) -> + case readHex [x | x <- bs, x /= '-'] of + [(val, "")] -> val + _ -> error "Vertex number is incorrect" + AlphaBinding _ obj -> getMaxNu obj + _ -> minNu + +intToBytesObject :: Int -> Object +intToBytesObject n = Formation [DeltaBinding $ intToBytes n] + nuCountAsDataObj :: Object -> Object -nuCountAsDataObj = intToBytesObject . nuCount +nuCountAsDataObj = intToBytesObject . getMaxNu diff --git a/src/Language/EO/Phi/Rules/Yaml.hs b/src/Language/EO/Phi/Rules/Yaml.hs --- a/src/Language/EO/Phi/Rules/Yaml.hs +++ b/src/Language/EO/Phi/Rules/Yaml.hs @@ -3,21 +3,31 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-partial-fields #-} module Language.EO.Phi.Rules.Yaml where +import Control.Lens ((+=)) +import Control.Monad (guard) +import Control.Monad.State (State, evalState, gets) import Data.Aeson (FromJSON (..), Options (sumEncoding), SumEncoding (UntaggedValue), genericParseJSON) import Data.Aeson.Types (defaultOptions) import Data.Coerce (coerce) +import Data.List (intercalate) import Data.List.NonEmpty qualified as NonEmpty import Data.Maybe (fromMaybe) import Data.String (IsString (..)) +import Data.String.Interpolate (i) import Data.Yaml qualified as Yaml import GHC.Generics (Generic) -import Language.EO.Phi.Rules.Common (Context (outerFormations)) +import Language.EO.Phi (printTree) +import Language.EO.Phi.Rules.Common (Context (insideFormation, outerFormations), NamedRule) import Language.EO.Phi.Rules.Common qualified as Common import Language.EO.Phi.Syntax.Abs @@ -39,6 +49,7 @@ data RuleContext = RuleContext { global_object :: Maybe Object , current_object :: Maybe Object + , current_attribute :: Maybe Attribute } deriving (Generic, FromJSON, Show) @@ -56,8 +67,7 @@ data RuleTest = RuleTest { name :: String , input :: Object - , output :: Object - , matches :: Bool + , output :: [Object] } deriving (Generic, FromJSON, Show) @@ -67,10 +77,12 @@ } deriving (Generic, Show, FromJSON) data Condition - = IsNF {nf :: [MetaId]} + = IsNF {nf :: Object} + | IsNFInsideFormation {nf_inside_formation :: Object} | PresentAttrs {present_attrs :: AttrsInBindings} | AbsentAttrs {absent_attrs :: AttrsInBindings} | AttrNotEqual {not_equal :: (Attribute, Attribute)} + | ApplyInSubformations {apply_in_subformations :: Bool} deriving (Generic, Show) instance FromJSON Condition where parseJSON = genericParseJSON defaultOptions{sumEncoding = UntaggedValue} @@ -79,23 +91,34 @@ parseRuleSetFromFile = Yaml.decodeFileThrow convertRule :: Rule -> Common.Rule -convertRule Rule{..} ctx obj = - [ obj' - | contextSubsts <- matchContext ctx context - , let pattern' = applySubst contextSubsts pattern - , let result' = applySubst contextSubsts result - , subst <- matchObject pattern' obj - , all (\cond -> checkCond ctx cond subst) when - , obj' <- [applySubst subst (evaluateMetaFuncs result')] - , not (objectHasMetavars obj') - ] +convertRule Rule{..} ctx obj = do + contextSubsts <- matchContext ctx context + let pattern' = applySubst contextSubsts pattern + result' = applySubst contextSubsts result + subst <- matchObject pattern' obj + guard $ all (\cond -> checkCond ctx cond (contextSubsts <> subst)) when + let result'' = applySubst (contextSubsts <> subst) result' + -- TODO #152:30m what context should we pass to evaluate meta funcs? + obj' = evaluateMetaFuncs obj result'' + guard $ not (objectHasMetavars obj') + pure obj' +convertRuleNamed :: Rule -> NamedRule +convertRuleNamed rule = (rule.name, convertRule rule) + +-- >>> matchContext (Context [] ["⟦ a ↦ ⟦ ⟧, x ↦ ξ.a ⟧"] (Label (LabelId "x"))) (Just (RuleContext Nothing (Just "⟦ !a ↦ !obj, !B ⟧") (Just "!a"))) +-- [Subst { +-- objectMetas = [!obj -> 'ξ.a'] +-- bindingsMetas = [!B -> 'a ↦ ⟦ ⟧'] +-- attributeMetas = [!a -> 'x'] +-- }] matchContext :: Common.Context -> Maybe RuleContext -> [Subst] matchContext Common.Context{} Nothing = [emptySubst] -matchContext Common.Context{..} (Just (RuleContext p1 p2)) = do - subst1 <- maybe [emptySubst] (`matchObject` globalObject) p1 - subst2 <- maybe [emptySubst] ((`matchObject` thisObject) . applySubst subst1) p2 - return (subst1 <> subst2) +matchContext Common.Context{..} (Just (RuleContext{..})) = do + subst1 <- maybe [emptySubst] (`matchObject` globalObject) global_object + subst2 <- maybe [emptySubst] ((`matchObject` thisObject) . applySubst subst1) current_object + subst3 <- maybe [emptySubst] ((`matchAttr` currentAttr) . applySubstAttr (subst1 <> subst2)) current_attribute + return (subst1 <> subst2 <> subst3) where globalObject = NonEmpty.last outerFormations thisObject = NonEmpty.head outerFormations @@ -114,8 +137,10 @@ bindingHasMetavars (AlphaBinding attr obj) = attrHasMetavars attr || objectHasMetavars obj bindingHasMetavars (EmptyBinding attr) = attrHasMetavars attr bindingHasMetavars (DeltaBinding _) = False +bindingHasMetavars DeltaEmptyBinding = False bindingHasMetavars (LambdaBinding _) = False bindingHasMetavars (MetaBindings _) = True +bindingHasMetavars (MetaDeltaBinding _) = True attrHasMetavars :: Attribute -> Bool attrHasMetavars Phi = False @@ -129,7 +154,8 @@ -- | Given a condition, and a substition from object matching -- tells whether the condition matches the object checkCond :: Common.Context -> Condition -> Subst -> Bool -checkCond ctx (IsNF metaIds) subst = all (Common.isNF ctx . applySubst subst . MetaObject) metaIds +checkCond ctx (IsNF obj) subst = Common.isNF ctx $ applySubst subst obj +checkCond ctx (IsNFInsideFormation obj) subst = Common.isNF ctx{insideFormation = True} $ applySubst subst obj checkCond _ctx (PresentAttrs (AttrsInBindings attrs bindings)) subst = any (`hasAttr` substitutedBindings) substitutedAttrs where substitutedBindings = concatMap (applySubstBinding subst) bindings @@ -146,6 +172,9 @@ substitutedAttrs = map (normalToRuleAttr . applySubstAttr subst . ruleToNormalAttr) attrs checkCond ctx (AbsentAttrs s) subst = not $ checkCond ctx (PresentAttrs s) subst checkCond _ctx (AttrNotEqual (a1, a2)) subst = applySubstAttr subst a1 /= applySubstAttr subst a2 +checkCond ctx (ApplyInSubformations shouldApply) _subst + | shouldApply = True + | otherwise = not (insideFormation ctx) hasAttr :: RuleAttribute -> [Binding] -> Bool hasAttr attr = any (isAttr attr) @@ -153,6 +182,7 @@ isAttr (ObjectAttr a) (AlphaBinding a' _) = a == a' isAttr (ObjectAttr a) (EmptyBinding a') = a == a' isAttr DeltaAttr (DeltaBinding _) = True + isAttr DeltaAttr DeltaEmptyBinding = True isAttr LambdaAttr (LambdaBinding _) = True isAttr _ _ = False @@ -173,8 +203,21 @@ { objectMetas :: [(MetaId, Object)] , bindingsMetas :: [(MetaId, [Binding])] , attributeMetas :: [(MetaId, Attribute)] + , bytesMetas :: [(MetaId, Bytes)] } - deriving (Show) +instance Show Subst where + show Subst{..} = + intercalate + "\n" + [ "Subst {" + , " objectMetas = [" <> showMappings objectMetas <> "]" + , " bindingsMetas = [" <> showMappings bindingsMetas <> "]" + , " attributeMetas = [" <> showMappings attributeMetas <> "]" + , " bytesMetas = [" <> showMappings bytesMetas <> "]" + , "}" + ] + where + showMappings metas = intercalate "; " $ map (\(MetaId metaId, obj) -> [i|#{metaId} -> '#{printTree obj}'|]) metas instance Semigroup Subst where (<>) = mergeSubst @@ -183,7 +226,7 @@ mempty = emptySubst emptySubst :: Subst -emptySubst = Subst [] [] [] +emptySubst = Subst [] [] [] [] -- >>> putStrLn $ Language.EO.Phi.printTree (applySubst (Subst [("!n", "⟦ c ↦ ⟦ ⟧ ⟧")] [("!B", ["b ↦ ⟦ ⟧"])] [("!a", "a")]) "!n(ρ ↦ ⟦ !B ⟧)" :: Object) -- ⟦ c ↦ ⟦ ⟧ ⟧ (ρ ↦ ⟦ b ↦ ⟦ ⟧ ⟧) @@ -215,12 +258,14 @@ EmptyBinding a -> [EmptyBinding (applySubstAttr subst a)] DeltaBinding bytes -> [DeltaBinding (coerce bytes)] + DeltaEmptyBinding -> [DeltaEmptyBinding] LambdaBinding bytes -> [LambdaBinding (coerce bytes)] b@(MetaBindings m) -> fromMaybe [b] (lookup m bindingsMetas) + b@(MetaDeltaBinding m) -> maybe [b] (pure . DeltaBinding) (lookup m bytesMetas) mergeSubst :: Subst -> Subst -> Subst -mergeSubst (Subst xs ys zs) (Subst xs' ys' zs') = - Subst (xs ++ xs') (ys ++ ys') (zs ++ zs') +mergeSubst (Subst xs ys zs ws) (Subst xs' ys' zs' ws') = + Subst (xs ++ xs') (ys ++ ys') (zs ++ zs') (ws ++ ws') -- 1. need to implement applySubst' :: Subst -> Object -> Object -- 2. complete the code @@ -235,38 +280,53 @@ subst2 <- matchAttr (applySubstAttr subst1 a) a' pure (subst1 <> subst2) matchObject (MetaObject m) obj = - pure - Subst - { objectMetas = [(m, obj)] - , bindingsMetas = [] - , attributeMetas = [] - } + pure emptySubst{objectMetas = [(m, obj)]} matchObject Termination Termination = [emptySubst] +matchObject ThisObject ThisObject = [emptySubst] +matchObject GlobalObject GlobalObject = [emptySubst] matchObject _ _ = [] -- ? emptySubst ? -evaluateMetaFuncs :: Object -> Object -evaluateMetaFuncs (MetaFunction (MetaFunctionName "@T") obj) = Common.nuCountAsDataObj obj -evaluateMetaFuncs (Formation bindings) = Formation (map evaluateMetaFuncsBinding bindings) -evaluateMetaFuncs (Application obj bindings) = Application (evaluateMetaFuncs obj) (map evaluateMetaFuncsBinding bindings) -evaluateMetaFuncs (ObjectDispatch obj a) = ObjectDispatch (evaluateMetaFuncs obj) a -evaluateMetaFuncs obj = obj +-- | Evaluate meta functions +-- given top-level context as an object +-- and an object +-- +-- >>> evaluateMetaFuncs "⟦ a ↦ ⟦ ν ↦ ⟦ Δ ⤍ 03- ⟧ ⟧, b ↦ ⟦ ⟧ ⟧" "⟦ a ↦ ⟦ ν ↦ @T(⟦ a ↦ ⟦ ν ↦ ⟦ Δ ⤍ 03- ⟧ ⟧, b ↦ ⟦ ⟧ ⟧) ⟧, b ↦ ⟦ ⟧ ⟧" +-- Formation [AlphaBinding (Label (LabelId "a")) (Formation [AlphaBinding VTX (Formation [DeltaBinding (Bytes "04-")])]),AlphaBinding (Label (LabelId "b")) (Formation [])] +evaluateMetaFuncs :: Object -> Object -> Object +evaluateMetaFuncs obj' obj = + evalState + (evaluateMetaFuncs' obj) + MetaState{nuCount = Common.getMaxNu obj' + 1} -evaluateMetaFuncsBinding :: Binding -> Binding -evaluateMetaFuncsBinding (AlphaBinding attr obj) = AlphaBinding attr (evaluateMetaFuncs obj) -evaluateMetaFuncsBinding binding = binding +newtype MetaState = MetaState + { nuCount :: Int + } + deriving (Generic) +evaluateMetaFuncs' :: Object -> State MetaState Object +evaluateMetaFuncs' (MetaFunction (MetaFunctionName "@T") _) = do + nuCount' <- gets (Common.intToBytesObject . nuCount) + #nuCount += 1 + pure nuCount' +evaluateMetaFuncs' (Formation bindings) = Formation <$> mapM evaluateMetaFuncsBinding bindings +evaluateMetaFuncs' (Application obj bindings) = Application <$> evaluateMetaFuncs' obj <*> mapM evaluateMetaFuncsBinding bindings +evaluateMetaFuncs' (ObjectDispatch obj a) = ObjectDispatch <$> evaluateMetaFuncs' obj <*> pure a +evaluateMetaFuncs' obj = pure obj + +evaluateMetaFuncsBinding :: Binding -> State MetaState Binding +evaluateMetaFuncsBinding (AlphaBinding attr obj) = AlphaBinding attr <$> evaluateMetaFuncs' obj +evaluateMetaFuncsBinding binding = pure binding + matchBindings :: [Binding] -> [Binding] -> [Subst] matchBindings [] [] = [emptySubst] matchBindings [MetaBindings b] bindings = pure - Subst - { objectMetas = [] - , bindingsMetas = [(b, bindings)] - , attributeMetas = [] + emptySubst + { bindingsMetas = [(b, bindings)] } matchBindings (p : ps) bs = do (bs', subst1) <- matchFindBinding p bs - subst2 <- matchBindings ps bs' + subst2 <- matchBindings (applySubstBindings subst1 ps) bs' pure (subst1 <> subst2) matchBindings [] _ = [] @@ -294,15 +354,20 @@ subst1 <- matchAttr a a' subst2 <- matchObject obj obj' pure (subst1 <> subst2) +matchBinding (MetaDeltaBinding m) (DeltaBinding bytes) = [emptySubst{bytesMetas = [(m, bytes)]}] +matchBinding (DeltaBinding bytes) (DeltaBinding bytes') + | bytes == bytes' = [emptySubst] +matchBinding DeltaEmptyBinding DeltaEmptyBinding = [emptySubst] +matchBinding (EmptyBinding a1) (EmptyBinding a2) = matchAttr a1 a2 +matchBinding (LambdaBinding f1) (LambdaBinding f2) + | f1 == f2 = [emptySubst] matchBinding _ _ = [] matchAttr :: Attribute -> Attribute -> [Subst] matchAttr l r | l == r = [emptySubst] matchAttr (MetaAttr metaId) attr = - [ Subst - { objectMetas = [] - , bindingsMetas = [] - , attributeMetas = [(metaId, attr)] + [ emptySubst + { attributeMetas = [(metaId, attr)] } ] matchAttr _ _ = [] diff --git a/src/Language/EO/Phi/Syntax/Abs.hs b/src/Language/EO/Phi/Syntax/Abs.hs --- a/src/Language/EO/Phi/Syntax/Abs.hs +++ b/src/Language/EO/Phi/Syntax/Abs.hs @@ -33,8 +33,10 @@ = AlphaBinding Attribute Object | EmptyBinding Attribute | DeltaBinding Bytes + | DeltaEmptyBinding | LambdaBinding Function | MetaBindings MetaId + | MetaDeltaBinding MetaId deriving (C.Eq, C.Ord, C.Show, C.Read, C.Data, C.Typeable, C.Generic) data Attribute diff --git a/src/Language/EO/Phi/Syntax/Lex.x b/src/Language/EO/Phi/Syntax/Lex.x --- a/src/Language/EO/Phi/Syntax/Lex.x +++ b/src/Language/EO/Phi/Syntax/Lex.x @@ -32,6 +32,12 @@ :- +-- Line comment "//" +"//" [.]* ; + +-- Block comment "/*" "*/" +\/ \* [$u # \*]* \* ([$u # [\* \/]] [$u # \*]* \* | \*)* \/ ; + -- Whitespace (skipped) $white+ ; diff --git a/src/Language/EO/Phi/Syntax/Par.y b/src/Language/EO/Phi/Syntax/Par.y --- a/src/Language/EO/Phi/Syntax/Par.y +++ b/src/Language/EO/Phi/Syntax/Par.y @@ -108,8 +108,10 @@ : Attribute '↦' Object { Language.EO.Phi.Syntax.Abs.AlphaBinding $1 $3 } | Attribute '↦' '∅' { Language.EO.Phi.Syntax.Abs.EmptyBinding $1 } | 'Δ' '⤍' Bytes { Language.EO.Phi.Syntax.Abs.DeltaBinding $3 } + | 'Δ' '⤍' '∅' { Language.EO.Phi.Syntax.Abs.DeltaEmptyBinding } | 'λ' '⤍' Function { Language.EO.Phi.Syntax.Abs.LambdaBinding $3 } | MetaId { Language.EO.Phi.Syntax.Abs.MetaBindings $1 } + | 'Δ' '⤍' MetaId { Language.EO.Phi.Syntax.Abs.MetaDeltaBinding $3 } ListBinding :: { [Language.EO.Phi.Syntax.Abs.Binding] } ListBinding diff --git a/src/Language/EO/Phi/Syntax/Print.hs b/src/Language/EO/Phi/Syntax/Print.hs --- a/src/Language/EO/Phi/Syntax/Print.hs +++ b/src/Language/EO/Phi/Syntax/Print.hs @@ -169,8 +169,10 @@ Language.EO.Phi.Syntax.Abs.AlphaBinding attribute object -> prPrec i 0 (concatD [prt 0 attribute, doc (showString "\8614"), prt 0 object]) Language.EO.Phi.Syntax.Abs.EmptyBinding attribute -> prPrec i 0 (concatD [prt 0 attribute, doc (showString "\8614"), doc (showString "\8709")]) Language.EO.Phi.Syntax.Abs.DeltaBinding bytes -> prPrec i 0 (concatD [doc (showString "\916"), doc (showString "\10509"), prt 0 bytes]) + Language.EO.Phi.Syntax.Abs.DeltaEmptyBinding -> prPrec i 0 (concatD [doc (showString "\916"), doc (showString "\10509"), doc (showString "\8709")]) Language.EO.Phi.Syntax.Abs.LambdaBinding function -> prPrec i 0 (concatD [doc (showString "\955"), doc (showString "\10509"), prt 0 function]) Language.EO.Phi.Syntax.Abs.MetaBindings metaid -> prPrec i 0 (concatD [prt 0 metaid]) + Language.EO.Phi.Syntax.Abs.MetaDeltaBinding metaid -> prPrec i 0 (concatD [doc (showString "\916"), doc (showString "\10509"), prt 0 metaid]) instance Print [Language.EO.Phi.Syntax.Abs.Binding] where prt _ [] = concatD [] diff --git a/src/Language/EO/Phi/TH.hs b/src/Language/EO/Phi/TH.hs new file mode 100644 --- /dev/null +++ b/src/Language/EO/Phi/TH.hs @@ -0,0 +1,12 @@ +module Language.EO.Phi.TH where + +import Data.Aeson (Options (..), camelTo2) +import Data.Aeson.TH as TH (deriveJSON) +import Data.Aeson.Types (defaultOptions) +import Language.Haskell.TH (Dec, Name, Q) + +defaultOptions' :: Options +defaultOptions' = defaultOptions{fieldLabelModifier = camelTo2 '-'} + +deriveJSON :: Name -> Q [Dec] +deriveJSON = TH.deriveJSON defaultOptions' diff --git a/test/Language/EO/Phi/DataizeSpec.hs b/test/Language/EO/Phi/DataizeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/EO/Phi/DataizeSpec.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RecordWildCards #-} + +module Language.EO.Phi.DataizeSpec where + +import Control.Monad (forM_) +import Test.Hspec + +import Language.EO.Phi qualified as Phi +import Language.EO.Phi.Dataize (dataizeRecursively) +import Language.EO.Phi.Rules.Common (defaultContext) +import Language.EO.Phi.Rules.Yaml (convertRuleNamed, parseRuleSetFromFile, rules) +import Test.EO.Phi (DataizeTest (..), DataizeTestGroup (..), dataizationTests) + +spec :: Spec +spec = do + DataizeTestGroup{..} <- runIO (dataizationTests "test/eo/phi/dataization.yaml") + ruleset <- runIO $ parseRuleSetFromFile "test/eo/phi/rules/yegor.yaml" + let rules = map convertRuleNamed ruleset.rules + describe title $ + forM_ tests $ + \test -> do + let inputObj = progToObj test.input + it test.name $ dataizeRecursively (defaultContext rules inputObj) inputObj `shouldBe` Right test.output + +progToObj :: Phi.Program -> Phi.Object +progToObj (Phi.Program bindings) = Phi.Formation bindings diff --git a/test/Language/EO/PhiSpec.hs b/test/Language/EO/PhiSpec.hs --- a/test/Language/EO/PhiSpec.hs +++ b/test/Language/EO/PhiSpec.hs @@ -16,8 +16,9 @@ import Data.String.Interpolate (i) import Data.Yaml (decodeFileThrow) import Language.EO.Phi -import Language.EO.Phi.Metrics.Collect (collectMetrics) -import Language.EO.Phi.Rules.Common (Context (..), Rule) +import Language.EO.Phi.Metrics.Collect (getProgramMetrics) +import Language.EO.Phi.Metrics.Data (BindingsByPathMetrics (..), ProgramMetrics (..)) +import Language.EO.Phi.Rules.Common (Rule, defaultContext, equalProgram) import Language.EO.Phi.Rules.PhiPaper (rule1, rule6) import Test.EO.Phi import Test.Hspec @@ -40,7 +41,7 @@ forM_ tests $ \PhiTest{..} -> it name $ - applyRule (rule (Context [] [progToObj input])) input `shouldBe` [normalized] + applyRule (rule (defaultContext [] (progToObj input))) input `shouldBe` [normalized] describe "Programs translated from EO" $ do phiTests <- runIO (allPhiTests "test/eo/phi/from-eo/") forM_ phiTests $ \PhiTestGroup{..} -> @@ -49,7 +50,7 @@ \PhiTest{..} -> do describe "normalize" $ it name $ - normalize input `shouldBe` normalized + normalize input `shouldSatisfy` equalProgram normalized describe "pretty-print" $ it name $ printTree input `shouldBe` trim prettified @@ -57,7 +58,7 @@ metricsTests <- runIO $ decodeFileThrow @_ @MetricsTestSet "test/eo/phi/metrics.yaml" forM_ metricsTests.tests $ \test -> do it test.title $ - collectMetrics (fromString @Program test.phi) `shouldBe` test.metrics + getProgramMetrics (fromString @Program test.phi) ((.path) <$> test.metrics.bindingsByPathMetrics) `shouldBe` Right test.metrics trim :: String -> String trim = dropWhileEnd isSpace diff --git a/test/Language/EO/Rules/PhiPaperSpec.hs b/test/Language/EO/Rules/PhiPaperSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/EO/Rules/PhiPaperSpec.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Language.EO.Rules.PhiPaperSpec where + +import Control.Monad (forM_, guard) +import Data.Aeson (FromJSON) +import Data.Data (Data (toConstr)) +import Data.List (intercalate) +import Data.List qualified as List +import Data.Yaml qualified as Yaml +import GHC.Generics (Generic) +import Language.EO.Phi.Rules.Common (ApplicationLimits (..), NamedRule, applyOneRule, defaultApplicationLimits, defaultContext, equalObject, intToBytes, objectSize) +import Language.EO.Phi.Rules.Yaml (convertRuleNamed, parseRuleSetFromFile, rules) +import Language.EO.Phi.Syntax (printTree) +import Language.EO.Phi.Syntax.Abs as Phi +import Test.Hspec +import Test.QuickCheck + +arbitraryNonEmptyString :: Gen String +arbitraryNonEmptyString = do + x <- elements ['a' .. 'z'] + n <- choose (1, 9 :: Int) + return (x : show n) + +instance Arbitrary Attribute where + arbitrary = + oneof + [ pure Phi + , pure Rho + , pure Sigma + , pure VTX + , Label <$> arbitrary + ] + +instance Arbitrary LabelId where + arbitrary = LabelId <$> arbitraryNonEmptyString + shrink = genericShrink +instance Arbitrary AlphaIndex where + arbitrary = AlphaIndex <$> arbitraryNonEmptyString +instance Arbitrary Bytes where + arbitrary = intToBytes <$> arbitrarySizedNatural +instance Arbitrary Phi.Function where + arbitrary = Phi.Function <$> arbitraryNonEmptyString +instance Arbitrary Phi.MetaId where + arbitrary = Phi.MetaId . ("!" ++) <$> arbitraryNonEmptyString +instance Arbitrary Phi.MetaFunctionName where + arbitrary = Phi.MetaFunctionName . ("@" ++) <$> arbitraryNonEmptyString + +instance Arbitrary Binding where + arbitrary = + oneof + [ EmptyBinding . Label <$> arbitrary + , do + attr <- arbitrary + obj <- case attr of + VTX -> + Formation <$> do + bytes <- arbitrary + return [DeltaBinding bytes] + _ -> arbitrary + return (AlphaBinding attr obj) + , DeltaBinding <$> arbitrary + , LambdaBinding <$> arbitrary + , pure DeltaEmptyBinding + ] + shrink (AlphaBinding VTX _) = [] -- do not shrink vertex bindings + shrink (AlphaBinding attr obj) = AlphaBinding attr <$> shrink obj + shrink _ = [] -- do not shrink deltas and lambdas + +instance Arbitrary Object where + arbitrary = sized $ \n -> do + let arbitraryBinding = resize (n `div` 2) arbitrary + arbitraryAttr = resize (n `div` 2) arbitrary + arbitraryObj = resize (n `div` 2) arbitrary + sameAttr (AlphaBinding attr1 _) (AlphaBinding attr2 _) = attr1 == attr2 + sameAttr (EmptyBinding attr1) (EmptyBinding attr2) = attr1 == attr2 + sameAttr b1 b2 = toConstr b1 == toConstr b2 + arbitraryBindings = List.nubBy sameAttr <$> listOf arbitraryBinding + arbitraryAlphaLabelBinding = + resize (n `div` 2) $ + AlphaBinding <$> (Label <$> arbitrary) <*> arbitrary + arbitraryAlphaLabelBindings = List.nubBy sameAttr <$> listOf arbitraryAlphaLabelBinding + if n > 0 + then + oneof + [ Formation <$> arbitraryBindings + , liftA2 Application arbitraryObj arbitraryAlphaLabelBindings + , liftA2 ObjectDispatch arbitraryObj arbitraryAttr + , ObjectDispatch GlobalObject <$> arbitraryAttr + , pure ThisObject + , pure Termination + ] + else pure $ Formation [] + shrink = genericShrink + +data CriticalPair = CriticalPair + { sourceTerm :: Object + , criticalPair :: (Object, Object) + , rulesApplied :: (String, String) + } + +genCriticalPair :: [NamedRule] -> Gen CriticalPair +genCriticalPair rules = do + (sourceTerm, results) <- fan `suchThat` \(_, rs) -> length rs > 1 + case results of + (rule1, x) : (rule2, y) : _ -> + return + CriticalPair + { sourceTerm = sourceTerm + , criticalPair = (x, y) + , rulesApplied = (rule1, rule2) + } + _ -> error "IMPOSSIBLE HAPPENED" + where + fan = do + obj <- Formation . List.nubBy sameAttr <$> listOf arbitrary + return (obj, applyOneRule (defaultContext rules obj) obj) + + sameAttr (AlphaBinding attr1 _) (AlphaBinding attr2 _) = attr1 == attr2 + sameAttr (EmptyBinding attr1) (EmptyBinding attr2) = attr1 == attr2 + sameAttr b1 b2 = toConstr b1 == toConstr b2 + +findCriticalPairs :: [NamedRule] -> Object -> [CriticalPair] +findCriticalPairs rules obj = do + let ctx = defaultContext rules obj + let results = applyOneRule ctx obj + guard (length results > 1) + case results of + (rule1, x) : (rule2, y) : _ -> + return + CriticalPair + { sourceTerm = obj + , criticalPair = (x, y) + , rulesApplied = (rule1, rule2) + } + _ -> error "IMPOSSIBLE HAPPENED" + +shrinkCriticalPair :: [NamedRule] -> CriticalPair -> [CriticalPair] +shrinkCriticalPair rules CriticalPair{..} = + [ CriticalPair + { sourceTerm = sourceTerm' + , criticalPair = (x, y) + , rulesApplied = (rule1, rule2) + } + | sourceTerm'@Formation{} <- shrink sourceTerm + , (rule1, x) : (rule2, y) : _ <- [applyOneRule (defaultContext rules sourceTerm') sourceTerm'] + ] + +type SearchLimits = ApplicationLimits + +descendantsN :: SearchLimits -> [NamedRule] -> [Object] -> [[Object]] +descendantsN ApplicationLimits{..} rules objs + | maxDepth <= 0 = [objs] + | otherwise = + objs + : descendantsN + ApplicationLimits{maxDepth = maxDepth - 1, ..} + rules + [ obj' + | obj <- objs + , objectSize obj < maxTermSize + , (_name, obj') <- applyOneRule (defaultContext rules obj) obj + ] + +-- | Pair items from two lists with all combinations, +-- but order them lexicographically according to their original indices. +-- This makes sure that we check pairs that are early in both lists +-- before checking pairs later. +-- +-- >>> pairByLevel [1..3] "abc" +-- [(1,'a'),(2,'a'),(1,'b'),(2,'b'),(3,'a'),(3,'b'),(1,'c'),(2,'c'),(3,'c')] +-- +-- Works for infinite lists as well: +-- +-- >>> take 10 $ pairByLevel [1..] [1..] +-- [(1,1),(2,1),(1,2),(2,2),(3,1),(3,2),(1,3),(2,3),(3,3),(4,1)] +pairByLevel :: [a] -> [b] -> [(a, b)] +pairByLevel = go [] [] + where + go :: [a] -> [b] -> [a] -> [b] -> [(a, b)] + go _xs _ys [] _ = [] + go _xs _ys _ [] = [] + go xs ys (a : as) (b : bs) = + map (a,) ys + ++ map (,b) xs + ++ (a, b) + : go (xs ++ [a]) (ys ++ [b]) as bs + +-- | Find intersection of two lists, represented as lists of groups. +-- Intersection of groups with lower indicies is considered before +-- moving on to groups with larger index. +intersectByLevelBy :: (a -> a -> Bool) -> [[a]] -> [[a]] -> [a] +intersectByLevelBy eq xs ys = + concat + [ List.intersectBy eq l r + | (l, r) <- pairByLevel xs ys + ] + +confluentCriticalPairN :: SearchLimits -> [NamedRule] -> CriticalPair -> Bool +confluentCriticalPairN limits rules CriticalPair{..} = + -- should normalize the VTXs before checking + -- NOTE: we are using intersectByLevelBy to ensure that we first check + -- terms generated after one rule application, then include terms after two rules applications, etc. + -- This helps find the confluence points without having to compute all terms up to depth N, + -- \**if** the term is confluent. + -- We expect confluence to be satisfied at depth 1 in practice for most terms, + -- since most critical pairs apply non-overlapping rules. + -- However, if the term is NOT confluent, we will still check all options, which may take some time. + not (null (intersectByLevelBy equalObject (descendantsN limits rules [x]) (descendantsN limits rules [y]))) + where + (x, y) = criticalPair + +instance Show CriticalPair where + show CriticalPair{criticalPair = (x, y), rulesApplied = (rule1, rule2), ..} = + intercalate + "\n" + [ "Source term:" + , " " <> printTree sourceTerm + , "Critical pair:" + , " Using rule '" <> rule1 <> "': " <> printTree x + , " Using rule '" <> rule2 <> "': " <> printTree y + ] + +defaultSearchLimits :: Int -> SearchLimits +defaultSearchLimits = defaultApplicationLimits + +confluent :: [NamedRule] -> Property +confluent rulesFromYaml = withMaxSuccess 1_000 $ + forAllShrink (resize 40 $ genCriticalPair rulesFromYaml) (shrinkCriticalPair rulesFromYaml) $ + \pair@CriticalPair{..} -> + within 100_000 $ -- 0.1 second timeout per test + confluentCriticalPairN (defaultSearchLimits (objectSize sourceTerm)) rulesFromYaml pair + +confluentOnObject :: [NamedRule] -> Object -> Bool +confluentOnObject rules obj = all (confluentCriticalPairN (defaultSearchLimits (objectSize obj)) rules) (findCriticalPairs rules obj) + +data ConfluenceTests = ConfluenceTests + { title :: String + , tests :: [Object] + } + deriving (Generic, FromJSON, Show) + +parseTests :: String -> IO ConfluenceTests +parseTests = Yaml.decodeFileThrow + +spec :: Spec +spec = do + ruleset <- runIO $ parseRuleSetFromFile "./test/eo/phi/rules/yegor.yaml" + let rulesFromYaml = map convertRuleNamed (rules ruleset) + inputs <- runIO $ parseTests "./test/eo/phi/confluence.yaml" + describe "Yegor's rules" $ do + it "Are confluent (via QuickCheck)" (confluent rulesFromYaml) + describe + "Are confluent (regression tests)" + $ forM_ (tests inputs) + $ \input -> do + it (printTree input) (input `shouldSatisfy` confluentOnObject rulesFromYaml) diff --git a/test/Language/EO/YamlSpec.hs b/test/Language/EO/YamlSpec.hs --- a/test/Language/EO/YamlSpec.hs +++ b/test/Language/EO/YamlSpec.hs @@ -5,8 +5,8 @@ module Language.EO.YamlSpec where import Control.Monad (forM_) -import Language.EO.Phi.Rules.Common (Context (..)) -import Language.EO.Phi.Rules.Yaml (Rule (..), RuleSet (..), RuleTest (..), convertRule) +import Language.EO.Phi.Rules.Common (applyOneRule, defaultContext, equalObject) +import Language.EO.Phi.Rules.Yaml (Rule (..), RuleSet (..), RuleTest (..), convertRuleNamed) import Test.EO.Yaml import Test.Hspec @@ -18,4 +18,8 @@ describe rule.name do forM_ rule.tests $ \ruleTest -> do it ruleTest.name $ - convertRule rule (Context [] [ruleTest.input]) ruleTest.input `shouldBe` [ruleTest.output | ruleTest.matches] + let rule' = convertRuleNamed rule + resultOneStep = applyOneRule (defaultContext [rule'] ruleTest.input) ruleTest.input + expected = ruleTest.output + sameObjs objs1 objs2 = and ((length objs1 == length objs2) : zipWith equalObject objs2 objs1) + in (map snd resultOneStep) `shouldSatisfy` sameObjs expected diff --git a/test/Test/EO/Phi.hs b/test/Test/EO/Phi.hs --- a/test/Test/EO/Phi.hs +++ b/test/Test/EO/Phi.hs @@ -1,6 +1,10 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} module Test.EO.Phi where @@ -30,9 +34,25 @@ } deriving (Generic, FromJSON) +data DataizeTestGroup = DataizeTestGroup + { title :: String + , tests :: [DataizeTest] + } + deriving (Generic, FromJSON) + +data DataizeTest = DataizeTest + { name :: String + , input :: Phi.Program + , output :: Phi.Bytes + } + deriving (Generic, FromJSON) + fileTests :: FilePath -> IO PhiTestGroup fileTests = Yaml.decodeFileThrow +dataizationTests :: FilePath -> IO DataizeTestGroup +dataizationTests = Yaml.decodeFileThrow + allPhiTests :: FilePath -> IO [PhiTestGroup] allPhiTests dir = do paths <- listDirectory dir @@ -44,3 +64,5 @@ -- | Parsing a $\varphi$-program from a JSON string. instance FromJSON Phi.Program where parseJSON = fmap unsafeParseProgram . parseJSON + +deriving newtype instance FromJSON Phi.Bytes diff --git a/test/Test/Metrics/Phi.hs b/test/Test/Metrics/Phi.hs --- a/test/Test/Metrics/Phi.hs +++ b/test/Test/Metrics/Phi.hs @@ -6,7 +6,7 @@ import Data.Yaml (FromJSON) import GHC.Generics (Generic) -import Language.EO.Phi.Metrics.Collect (Metrics) +import Language.EO.Phi.Metrics.Data (ProgramMetrics) data MetricsTestSet = MetricsTestSet { title :: String @@ -17,6 +17,6 @@ data MetricsTest = MetricsTest { title :: String , phi :: String - , metrics :: Metrics + , metrics :: ProgramMetrics } deriving (Generic, FromJSON)