eo-phi-normalizer 0.2.0 → 0.3.0
raw patch · 25 files changed
+2343/−232 lines, 25 filesdep +QuickCheckdep +aeson-prettydep +blaze-htmldep −optparse-genericnew-component:exe:normalizer
Dependencies added: QuickCheck, aeson-pretty, blaze-html, blaze-markup, file-embed, optparse-applicative, scientific, template-haskell, text
Dependencies removed: optparse-generic
Files
- CHANGELOG.md +37/−3
- app/Main.hs +438/−60
- eo-phi-normalizer.cabal +34/−5
- grammar/EO/Phi/Syntax.cf +10/−5
- report/main.js +65/−0
- report/styles.css +105/−0
- src/Language/EO/Phi/Dataize.hs +148/−0
- src/Language/EO/Phi/Metrics/Collect.hs +165/−55
- src/Language/EO/Phi/Metrics/Data.hs +232/−0
- src/Language/EO/Phi/Normalize.hs +11/−5
- src/Language/EO/Phi/Report/Data.hs +170/−0
- src/Language/EO/Phi/Report/Html.hs +274/−0
- src/Language/EO/Phi/Rules/Common.hs +188/−42
- src/Language/EO/Phi/Rules/Yaml.hs +112/−47
- src/Language/EO/Phi/Syntax/Abs.hs +2/−0
- src/Language/EO/Phi/Syntax/Lex.x +6/−0
- src/Language/EO/Phi/Syntax/Par.y +2/−0
- src/Language/EO/Phi/Syntax/Print.hs +2/−0
- src/Language/EO/Phi/TH.hs +12/−0
- test/Language/EO/Phi/DataizeSpec.hs +28/−0
- test/Language/EO/PhiSpec.hs +6/−5
- test/Language/EO/Rules/PhiPaperSpec.hs +265/−0
- test/Language/EO/YamlSpec.hs +7/−3
- test/Test/EO/Phi.hs +22/−0
- test/Test/Metrics/Phi.hs +2/−2
CHANGELOG.md view
@@ -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.
app/Main.hs view
@@ -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
eo-phi-normalizer.cabal view
@@ -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 <https://github.com/objectionary/eo-phi-normalizer#readme> 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
grammar/EO/Phi/Syntax.cf view
@@ -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
+ report/main.js view
@@ -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) {}+});
+ report/styles.css view
@@ -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;+}
+ src/Language/EO/Phi/Dataize.hs view
@@ -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, ())
src/Language/EO/Phi/Metrics/Collect.hs view
@@ -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, ..}
+ src/Language/EO/Phi/Metrics/Data.hs view
@@ -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)
src/Language/EO/Phi/Normalize.hs view
@@ -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
+ src/Language/EO/Phi/Report/Data.hs view
@@ -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+ , ..+ }
+ src/Language/EO/Phi/Report/Html.hs view
@@ -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)+-- "<td class=\"number bad\">0.2\128308</td>"+--+-- >>> renderHtml $ toHtmlChange reportConfig (MetricsChange'Good 0.5)+-- "<td class=\"number good\">0.5\128994</td>"+-- >>> renderHtml $ toHtmlChange reportConfig (MetricsChange'NA :: MetricsChangeCategory Double)+-- "<td class=\"number not-applicable\">N/A\128995</td>"+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
src/Language/EO/Phi/Rules/Common.hs view
@@ -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
src/Language/EO/Phi/Rules/Yaml.hs view
@@ -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 _ _ = []
src/Language/EO/Phi/Syntax/Abs.hs view
@@ -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
src/Language/EO/Phi/Syntax/Lex.x view
@@ -32,6 +32,12 @@ :- +-- Line comment "//"+"//" [.]* ;++-- Block comment "/*" "*/"+\/ \* [$u # \*]* \* ([$u # [\* \/]] [$u # \*]* \* | \*)* \/ ;+ -- Whitespace (skipped) $white+ ;
src/Language/EO/Phi/Syntax/Par.y view
@@ -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
src/Language/EO/Phi/Syntax/Print.hs view
@@ -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 []
+ src/Language/EO/Phi/TH.hs view
@@ -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'
+ test/Language/EO/Phi/DataizeSpec.hs view
@@ -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
test/Language/EO/PhiSpec.hs view
@@ -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
+ test/Language/EO/Rules/PhiPaperSpec.hs view
@@ -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)
test/Language/EO/YamlSpec.hs view
@@ -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
test/Test/EO/Phi.hs view
@@ -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
test/Test/Metrics/Phi.hs view
@@ -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)