diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,38 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## v0.4.1 — 2024-06-12 + +Changes and fixes: + +- Undo injection of top-level Package lambda ([#392](https://github.com/objectionary/normalizer/pull/392)) +- Fix dataization ([#395](https://github.com/objectionary/normalizer/pull/395)) + - Fix dataization inside $\varphi$ when `--minimize-stuck-terms` is enabled (closes [#393](https://github.com/objectionary/normalizer/pull/393)) + - Fix evaluation of atoms stuck on other atoms (fixes `while-dataizes-only-first-cycle` in `while-tests.phi`) + - Improve pretty-printing (closes [#292](https://github.com/objectionary/normalizer/pull/292)) + +- Fix pipeline script to run tests on normalized EO ([#396](https://github.com/objectionary/normalizer/pull/396)) + +- Changes to normalizer ([#396](https://github.com/objectionary/normalizer/pull/396)) + - Add `--wrap-raw-bytes` to automatically convert raw bytes (and terminations) in the output. This is a temporary fix, pending the change mentioned in + - Fix builtin normalizer to produce termination in some situations + - Fix dataization inside application/dispatch + - Fix encoding for strings to follow UTF-8 (compatibility with EO) + - Fix bool representation to require one byte (compatibility with EO) + - Fix integer division to truncate toward zero (compatibility with EO) + - Improve pretty-printer (use indentation) + - Update some examples/docs on the site + - Support up to 3 positional arguments in the builtin normalizer + +- Fix directory used in CI for: + - Job summary ([#402](https://github.com/objectionary/normalizer/pull/402)) + - Report ([#412](https://github.com/objectionary/normalizer/pull/412)) + +Documentation and maintenance: + +- Bring rules up to date ([#401](https://github.com/objectionary/normalizer/pull/401)) +- Update dependency prettier to v3.3.2 ([#385](https://github.com/objectionary/normalizer/pull/385)) + ## v0.4.0 — 2024-06-03 This version supports fast dataization with built-in rules and improves metrics with both built-in and user-defined rules (via YAML). diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -40,7 +40,7 @@ import Data.Text.Lazy as TL (unpack) import Data.Yaml (decodeFileThrow) import GHC.Generics (Generic) -import Language.EO.Phi (Binding (LambdaBinding), Bytes (Bytes), Object (Formation), Program (Program), parseProgram, printTree) +import Language.EO.Phi (Binding (..), Bytes (Bytes), Object (..), Program (Program), parseProgram, printTree) import Language.EO.Phi.Dataize import Language.EO.Phi.Dependencies import Language.EO.Phi.Metrics.Collect as Metrics (getProgramMetrics) @@ -85,6 +85,7 @@ , latex :: Bool , asPackage :: Bool , minimizeStuckTerms :: Bool + , wrapRawBytes :: Bool } deriving (Show) @@ -231,6 +232,7 @@ outputFile <- outputFileOption recursive <- switch (long "recursive" <> help "Apply dataization + normalization recursively.") chain <- switch (long "chain" <> help "Display all the intermediate steps.") + wrapRawBytes <- switch (long "wrap-raw-bytes" <> help "Wrap raw bytes ⟦ Δ ⤍ 01- ⟧ as Φ.org.eolang.bytes(Δ ⤍ 01-) in the final output.") latex <- latexSwitch asPackage <- asPackageSwitch minimizeStuckTerms <- minimizeStuckTermsSwitch @@ -387,6 +389,47 @@ | any isPackageBinding bs = bs | otherwise = bs ++ [LambdaBinding "Package"] +removeLambdaPackage :: Object -> Object +removeLambdaPackage = \case + Formation bindings -> + Formation + [ binding + | binding <- bindings + , not (isLambdaPackage binding) + ] + obj -> obj + +isLambdaPackage :: Binding -> Bool +isLambdaPackage (LambdaBinding "Package") = True +isLambdaPackage _ = False + +wrapRawBytesIn :: Object -> Object +wrapRawBytesIn = \case + Formation [DeltaBinding bytes] -> wrapBytesInBytes bytes + Formation bindings -> + Formation + [ case binding of + AlphaBinding a obj -> AlphaBinding a (wrapRawBytesIn obj) + _ -> binding + | binding <- bindings + ] + Application obj bindings -> + Application + (wrapRawBytesIn obj) + [ case binding of + AlphaBinding a attached -> AlphaBinding a (wrapRawBytesIn attached) + _ -> binding + | binding <- bindings + ] + ObjectDispatch obj a -> + ObjectDispatch (wrapRawBytesIn obj) a + GlobalObject -> GlobalObject + ThisObject -> ThisObject + Termination -> wrapTermination + obj@MetaSubstThis{} -> obj + obj@MetaObject{} -> obj + obj@MetaFunction{} -> obj + -- * Main main :: IO () @@ -512,7 +555,14 @@ | recursive = dataizeRecursively | otherwise = dataizeStep' case dataize ctx inputObject of - Left obj -> logStrLn (printAsProgramOrAsObject obj) + Left obj -> + let obj' + | asPackage = removeLambdaPackage obj + | otherwise = obj + obj'' + | wrapRawBytes = wrapRawBytesIn obj' + | otherwise = obj' + in logStrLn (printAsProgramOrAsObject obj'') Right (Bytes bytes) -> logStrLn bytes CLI'ReportPhi' CLI'ReportPhi{..} -> do pipelineConfig <- decodeFileThrow @_ @PipelineConfig configFile diff --git a/eo-phi-normalizer.cabal b/eo-phi-normalizer.cabal --- a/eo-phi-normalizer.cabal +++ b/eo-phi-normalizer.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: eo-phi-normalizer -version: 0.4.0 +version: 0.4.1 synopsis: Command line normalizer of 𝜑-calculus expressions. description: Please see the README on GitHub at homepage: https://github.com/objectionary/eo-phi-normalizer#readme diff --git a/src/Language/EO/Phi/Dataize.hs b/src/Language/EO/Phi/Dataize.hs --- a/src/Language/EO/Phi/Dataize.hs +++ b/src/Language/EO/Phi/Dataize.hs @@ -9,13 +9,13 @@ module Language.EO.Phi.Dataize where -import Control.Arrow (left) import Data.Bits import Data.List (singleton) import Data.List.NonEmpty qualified as NonEmpty -- import Data.List.NonEmpty qualified as NonEmpty import Data.Maybe (listToMaybe) +import Language.EO.Phi (printTree) import Language.EO.Phi.Rules.Common import Language.EO.Phi.Rules.Fast (fastYegorInsideOut) import Language.EO.Phi.Rules.Yaml (substThis) @@ -51,15 +51,20 @@ | Just (LambdaBinding (Function funcName)) <- listToMaybe [b | b@(LambdaBinding _) <- bs] , not hasEmpty = do logStep ("Evaluating lambda '" <> funcName <> "'") (Left obj) - (obj', _state) <- evaluateBuiltinFunChain funcName obj () - ctx <- getContext - return (ctx, Left obj') + msplit (evaluateBuiltinFunChain funcName obj ()) >>= \case + Nothing -> do + ctx <- getContext + return (ctx, Left obj) + Just ((obj', _state), _alts) -> do + ctx <- getContext + return (ctx, Left obj') | Just (AlphaBinding Phi decoratee) <- listToMaybe [b | b@(AlphaBinding Phi _) <- bs] , not hasEmpty = do - logStep "Dataizing inside phi" (Left decoratee) + let decoratee' = substThis obj decoratee + logStep "Dataizing inside phi" (Left decoratee') ctx <- getContext let extendedContext = (extendContextWith obj ctx){currentAttr = Phi} - return (extendedContext, Left (substThis obj decoratee)) + return (extendedContext, Left decoratee') | otherwise = do logStep "No change to formation" (Left obj) ctx <- getContext @@ -74,13 +79,17 @@ logStep "Dataizing inside application" (Left obj) modifyContext (\c -> c{dataizePackage = False}) $ do (ctx, obj') <- dataizeStepChain obj - return (ctx, left (`Application` bindings) obj') + case obj' of + Left obj'' -> return (ctx, Left (obj'' `Application` bindings)) + Right bytes -> return (ctx, Left (Formation [DeltaBinding bytes] `Application` bindings)) -- IMPORTANT: dataize the object being dispatched IF normalization is stuck on it! dataizeStepChain (ObjectDispatch obj attr) = incLogLevel $ do logStep "Dataizing inside dispatch" (Left obj) modifyContext (\c -> c{dataizePackage = False}) $ do (ctx, obj') <- dataizeStepChain obj - return (ctx, left (`ObjectDispatch` attr) obj') + case obj' of + Left obj'' -> return (ctx, Left (obj'' `ObjectDispatch` attr)) + Right bytes -> return (ctx, Left (Formation [DeltaBinding bytes] `ObjectDispatch` attr)) dataizeStepChain obj = do logStep "Nothing to dataize" (Left obj) ctx <- getContext @@ -153,12 +162,12 @@ resultObj = wrapBytes bytes logStep "Evaluated function" (Left resultObj) return resultObj - _ -> do - logStep "Couldn't find bytes in one or both of LHS and RHS" (Left Termination) - return Termination + _ -> fail "Couldn't find bytes in one or both of LHS and RHS" return (result, ()) evaluateBinaryDataizationFunChain :: + -- | Name of the atom. + String -> -- | How to convert the result back to bytes (res -> Bytes) -> -- | How to interpret the bytes in terms of the given data type @@ -174,7 +183,7 @@ Object -> EvaluationState -> DataizeChain (Object, EvaluationState) -evaluateBinaryDataizationFunChain resultToBytes bytesToParam wrapBytes arg1 arg2 func obj _state = do +evaluateBinaryDataizationFunChain name resultToBytes bytesToParam wrapBytes arg1 arg2 func obj _state = do let lhsArg = arg1 obj let rhsArg = arg2 obj lhs <- incLogLevel $ do @@ -189,19 +198,17 @@ resultObj = wrapBytes bytes logStep "Evaluated function" (Left resultObj) return resultObj - (Left _l, Left _r) -> do - logStep "Couldn't find bytes in both LHS and RHS" (Left Termination) - return Termination -- (Formation [AlphaBinding (Label "lhs") l, AlphaBinding (Label "rhs") r]) - (Left _l, _) -> do - logStep "Couldn't find bytes in LHS" (Left Termination) - return Termination -- (Formation [AlphaBinding (Label "lhs") (hideRho1 l)]) - (_, Left _r) -> do - logStep "Couldn't find bytes in RHS" (Left Termination) - return Termination -- (Formation [AlphaBinding (Label "rhs") r]) + (Left _l, Left _r) -> + fail (name <> ": Couldn't find bytes in both LHS and RHS") + (Left l, _) -> do + fail (name <> ": Couldn't find bytes in LHS: " <> printTree (hideRho l)) + (_, Left r) -> do + fail (name <> ": Couldn't find bytes in RHS: " <> printTree (hideRho r)) return (result, ()) -- | Unary functions operate on the given object without any additional parameters evaluateUnaryDataizationFunChain :: + String -> -- | How to convert the result back to bytes (res -> Bytes) -> -- | How to interpret the bytes in terms of the given data type @@ -215,8 +222,8 @@ Object -> EvaluationState -> DataizeChain (Object, EvaluationState) -evaluateUnaryDataizationFunChain resultToBytes bytesToParam wrapBytes extractArg func = - evaluateBinaryDataizationFunChain resultToBytes bytesToParam wrapBytes extractArg extractArg (const . func) +evaluateUnaryDataizationFunChain name resultToBytes bytesToParam wrapBytes extractArg func = + evaluateBinaryDataizationFunChain name resultToBytes bytesToParam wrapBytes extractArg extractArg (const . func) evaluateIODataizationFunChain :: IO String -> Object -> EvaluationState -> DataizeChain (Object, EvaluationState) evaluateIODataizationFunChain action _obj state = @@ -236,6 +243,10 @@ wrapBytesInString (Bytes bytes) = [fmt|Φ.org.eolang.string(as-bytes ↦ Φ.org.eolang.bytes(Δ ⤍ {bytes}))|] wrapBytesInBytes :: Bytes -> Object wrapBytesInBytes (Bytes bytes) = [fmt|Φ.org.eolang.bytes(Δ ⤍ {bytes})|] +wrapTermination :: Object +wrapTermination = [fmt|Φ.org.eolang.error(α0 ↦ Φ.org.eolang.string(as-bytes ↦ Φ.org.eolang.bytes(Δ ⤍ {bytes})))|] + where + Bytes bytes = stringToBytes "unknown error" wrapBytesAsBool :: Bytes -> Object wrapBytesAsBool bytes @@ -243,82 +254,82 @@ | otherwise = [fmt|Φ.org.eolang.true|] -- This should maybe get converted to a type class and some instances? -evaluateIntIntIntFunChain :: (Int -> Int -> Int) -> Object -> EvaluationState -> DataizeChain (Object, EvaluationState) -evaluateIntIntIntFunChain = evaluateBinaryDataizationFunChain intToBytes bytesToInt wrapBytesInInt extractRho (extractLabel "x") +evaluateIntIntIntFunChain :: String -> (Int -> Int -> Int) -> Object -> EvaluationState -> DataizeChain (Object, EvaluationState) +evaluateIntIntIntFunChain name = evaluateBinaryDataizationFunChain name intToBytes bytesToInt wrapBytesInInt extractRho (extractLabel "x") -evaluateIntIntBoolFunChain :: (Int -> Int -> Bool) -> Object -> EvaluationState -> DataizeChain (Object, EvaluationState) -evaluateIntIntBoolFunChain = evaluateBinaryDataizationFunChain boolToBytes bytesToInt wrapBytesAsBool extractRho (extractLabel "x") +evaluateIntIntBoolFunChain :: String -> (Int -> Int -> Bool) -> Object -> EvaluationState -> DataizeChain (Object, EvaluationState) +evaluateIntIntBoolFunChain name = evaluateBinaryDataizationFunChain name boolToBytes bytesToInt wrapBytesAsBool extractRho (extractLabel "x") -- Int because Bytes are just a string, but Int has a Bits instance -evaluateBytesBytesBytesFunChain :: (Int -> Int -> Int) -> Object -> EvaluationState -> DataizeChain (Object, EvaluationState) -evaluateBytesBytesBytesFunChain = evaluateBinaryDataizationFunChain intToBytes bytesToInt wrapBytesInBytes extractRho (extractLabel "b") +evaluateBytesBytesBytesFunChain :: String -> (Int -> Int -> Int) -> Object -> EvaluationState -> DataizeChain (Object, EvaluationState) +evaluateBytesBytesBytesFunChain name = evaluateBinaryDataizationFunChain name intToBytes bytesToInt wrapBytesInBytes extractRho (extractLabel "b") -evaluateBytesBytesFunChain :: (Int -> Int) -> Object -> EvaluationState -> DataizeChain (Object, EvaluationState) -evaluateBytesBytesFunChain = evaluateUnaryDataizationFunChain intToBytes bytesToInt wrapBytesInBytes extractRho +evaluateBytesBytesFunChain :: String -> (Int -> Int) -> Object -> EvaluationState -> DataizeChain (Object, EvaluationState) +evaluateBytesBytesFunChain name = evaluateUnaryDataizationFunChain name intToBytes bytesToInt wrapBytesInBytes extractRho -evaluateFloatFloatFloatFunChain :: (Double -> Double -> Double) -> Object -> EvaluationState -> DataizeChain (Object, EvaluationState) -evaluateFloatFloatFloatFunChain = evaluateBinaryDataizationFunChain floatToBytes bytesToFloat wrapBytesInFloat extractRho (extractLabel "x") +evaluateFloatFloatFloatFunChain :: String -> (Double -> Double -> Double) -> Object -> EvaluationState -> DataizeChain (Object, EvaluationState) +evaluateFloatFloatFloatFunChain name = evaluateBinaryDataizationFunChain name floatToBytes bytesToFloat wrapBytesInFloat extractRho (extractLabel "x") -- | Like `evaluateDataizationFunChain` but specifically for the built-in functions. -- This function is not safe. It returns undefined for unknown functions evaluateBuiltinFunChain :: String -> Object -> EvaluationState -> DataizeChain (Object, EvaluationState) -- int -evaluateBuiltinFunChain "Lorg_eolang_int_gt" obj = evaluateIntIntBoolFunChain (>) obj -evaluateBuiltinFunChain "Lorg_eolang_int_plus" obj = evaluateIntIntIntFunChain (+) obj -evaluateBuiltinFunChain "Lorg_eolang_int_times" obj = evaluateIntIntIntFunChain (*) obj -evaluateBuiltinFunChain "Lorg_eolang_int_div" obj = evaluateIntIntIntFunChain div obj +evaluateBuiltinFunChain name@"Lorg_eolang_int_gt" obj = evaluateIntIntBoolFunChain name (>) obj +evaluateBuiltinFunChain name@"Lorg_eolang_int_plus" obj = evaluateIntIntIntFunChain name (+) obj +evaluateBuiltinFunChain name@"Lorg_eolang_int_times" obj = evaluateIntIntIntFunChain name (*) obj +evaluateBuiltinFunChain name@"Lorg_eolang_int_div" obj = evaluateIntIntIntFunChain name quot obj -- bytes -evaluateBuiltinFunChain "Lorg_eolang_bytes_eq" obj = evaluateBinaryDataizationFunChain boolToBytes bytesToInt wrapBytesAsBool extractRho (extractLabel "b") (==) obj -evaluateBuiltinFunChain "Lorg_eolang_bytes_size" obj = evaluateUnaryDataizationFunChain intToBytes id wrapBytesInBytes extractRho (\(Bytes bytes) -> length (words (map dashToSpace bytes))) obj +evaluateBuiltinFunChain name@"Lorg_eolang_bytes_eq" obj = evaluateBinaryDataizationFunChain name boolToBytes bytesToInt wrapBytesAsBool extractRho (extractLabel "b") (==) obj +evaluateBuiltinFunChain name@"Lorg_eolang_bytes_size" obj = evaluateUnaryDataizationFunChain name intToBytes id wrapBytesInBytes extractRho (\(Bytes bytes) -> length (words (map dashToSpace bytes))) obj where dashToSpace '-' = ' ' dashToSpace c = c -evaluateBuiltinFunChain "Lorg_eolang_bytes_slice" obj = \state -> do +evaluateBuiltinFunChain name@"Lorg_eolang_bytes_slice" obj = \state -> do thisStr <- incLogLevel $ dataizeRecursivelyChain True (extractRho obj) bytes <- case thisStr of Right bytes -> pure bytes Left _ -> fail "Couldn't find bytes" - evaluateBinaryDataizationFunChain id bytesToInt wrapBytesInBytes (extractLabel "start") (extractLabel "len") (sliceBytes bytes) obj state -evaluateBuiltinFunChain "Lorg_eolang_bytes_and" obj = evaluateBytesBytesBytesFunChain (.&.) obj -evaluateBuiltinFunChain "Lorg_eolang_bytes_or" obj = evaluateBytesBytesBytesFunChain (.|.) obj -evaluateBuiltinFunChain "Lorg_eolang_bytes_xor" obj = evaluateBytesBytesBytesFunChain (.^.) obj -evaluateBuiltinFunChain "Lorg_eolang_bytes_not" obj = evaluateBytesBytesFunChain complement obj -evaluateBuiltinFunChain "Lorg_eolang_bytes_right" obj = evaluateBinaryDataizationFunChain intToBytes bytesToInt wrapBytesInBytes extractRho (extractLabel "x") (\x i -> shift x (-i)) obj -evaluateBuiltinFunChain "Lorg_eolang_bytes_concat" obj = evaluateBinaryDataizationFunChain id id wrapBytesInBytes extractRho (extractLabel "b") concatBytes obj + evaluateBinaryDataizationFunChain name id bytesToInt wrapBytesInBytes (extractLabel "start") (extractLabel "len") (sliceBytes bytes) obj state +evaluateBuiltinFunChain name@"Lorg_eolang_bytes_and" obj = evaluateBytesBytesBytesFunChain name (.&.) obj +evaluateBuiltinFunChain name@"Lorg_eolang_bytes_or" obj = evaluateBytesBytesBytesFunChain name (.|.) obj +evaluateBuiltinFunChain name@"Lorg_eolang_bytes_xor" obj = evaluateBytesBytesBytesFunChain name (.^.) obj +evaluateBuiltinFunChain name@"Lorg_eolang_bytes_not" obj = evaluateBytesBytesFunChain name complement obj +evaluateBuiltinFunChain name@"Lorg_eolang_bytes_right" obj = evaluateBinaryDataizationFunChain name intToBytes bytesToInt wrapBytesInBytes extractRho (extractLabel "x") (\x i -> shift x (-i)) obj +evaluateBuiltinFunChain name@"Lorg_eolang_bytes_concat" obj = evaluateBinaryDataizationFunChain name id id wrapBytesInBytes extractRho (extractLabel "b") concatBytes obj -- float -evaluateBuiltinFunChain "Lorg_eolang_float_gt" obj = evaluateBinaryDataizationFunChain boolToBytes bytesToFloat wrapBytesInBytes extractRho (extractLabel "x") (>) obj -evaluateBuiltinFunChain "Lorg_eolang_float_times" obj = evaluateFloatFloatFloatFunChain (*) obj -evaluateBuiltinFunChain "Lorg_eolang_float_plus" obj = evaluateFloatFloatFloatFunChain (+) obj -evaluateBuiltinFunChain "Lorg_eolang_float_div" obj = evaluateFloatFloatFloatFunChain (/) obj +evaluateBuiltinFunChain name@"Lorg_eolang_float_gt" obj = evaluateBinaryDataizationFunChain name boolToBytes bytesToFloat wrapBytesInBytes extractRho (extractLabel "x") (>) obj +evaluateBuiltinFunChain name@"Lorg_eolang_float_times" obj = evaluateFloatFloatFloatFunChain name (*) obj +evaluateBuiltinFunChain name@"Lorg_eolang_float_plus" obj = evaluateFloatFloatFloatFunChain name (+) obj +evaluateBuiltinFunChain name@"Lorg_eolang_float_div" obj = evaluateFloatFloatFloatFunChain name (/) obj -- string -evaluateBuiltinFunChain "Lorg_eolang_string_length" obj = evaluateUnaryDataizationFunChain intToBytes bytesToString wrapBytesInInt extractRho length obj -evaluateBuiltinFunChain "Lorg_eolang_string_slice" obj = \state -> do +evaluateBuiltinFunChain name@"Lorg_eolang_string_length" obj = evaluateUnaryDataizationFunChain name intToBytes bytesToString wrapBytesInInt extractRho length obj +evaluateBuiltinFunChain name@"Lorg_eolang_string_slice" obj = \state -> do thisStr <- incLogLevel $ dataizeRecursivelyChain True (extractRho obj) string <- case thisStr of Right bytes -> pure $ bytesToString bytes Left _ -> fail "Couldn't find bytes" - evaluateBinaryDataizationFunChain stringToBytes bytesToInt wrapBytesInString (extractLabel "start") (extractLabel "len") (\start len -> take len (drop start string)) obj state + evaluateBinaryDataizationFunChain name stringToBytes bytesToInt wrapBytesInString (extractLabel "start") (extractLabel "len") (\start len -> take len (drop start string)) obj state -- malloc --- evaluateBuiltinFunChain "Lorg_eolang_malloc_φ" obj = _ -- TODO --- evaluateBuiltinFunChain "Lorg_eolang_malloc_memory_block_pointer_read" obj = _ -- TODO --- evaluateBuiltinFunChain "Lorg_eolang_malloc_memory_block_pointer_write" obj = _ -- TODO --- evaluateBuiltinFunChain "Lorg_eolang_malloc_memory_block_pointer_free" obj = _ -- TODO +-- evaluateBuiltinFunChain name@"Lorg_eolang_malloc_φ" obj = _ -- TODO +-- evaluateBuiltinFunChain name@"Lorg_eolang_malloc_memory_block_pointer_read" obj = _ -- TODO +-- evaluateBuiltinFunChain name@"Lorg_eolang_malloc_memory_block_pointer_write" obj = _ -- TODO +-- evaluateBuiltinFunChain name@"Lorg_eolang_malloc_memory_block_pointer_free" obj = _ -- TODO -- cage --- evaluateBuiltinFunChain "Lorg_eolang_cage_φ" obj = _ -- TODO --- evaluateBuiltinFunChain "Lorg_eolang_cage_encaged_φ" obj = _ -- TODO --- evaluateBuiltinFunChain "Lorg_eolang_cage_encaged_encage" obj = _ -- TODO +-- evaluateBuiltinFunChain name@"Lorg_eolang_cage_φ" obj = _ -- TODO +-- evaluateBuiltinFunChain name@"Lorg_eolang_cage_encaged_φ" obj = _ -- TODO +-- evaluateBuiltinFunChain name@"Lorg_eolang_cage_encaged_encage" obj = _ -- TODO -- I/O --- evaluateBuiltinFunChain "Lorg_eolang_io_stdin_next_line" obj = evaluateIODataizationFunChain getLine obj --- evaluateBuiltinFunChain "Lorg_eolang_io_stdin_φ" obj = evaluateIODataizationFunChain getContents obj --- evaluateBuiltinFunChain "Lorg_eolang_io_stdout" obj = evaluateUnaryDataizationFunChain boolToBytes bytesToString wrapBytesInBytes (extractLabel "text") ((`seq` True) . unsafePerformIO . putStrLn) obj +-- evaluateBuiltinFunChain name@"Lorg_eolang_io_stdin_next_line" obj = evaluateIODataizationFunChain getLine obj +-- evaluateBuiltinFunChain name@"Lorg_eolang_io_stdin_φ" obj = evaluateIODataizationFunChain getContents obj +-- evaluateBuiltinFunChain name@"Lorg_eolang_io_stdout" obj = evaluateUnaryDataizationFunChain boolToBytes bytesToString wrapBytesInBytes (extractLabel "text") ((`seq` True) . unsafePerformIO . putStrLn) obj -- others -evaluateBuiltinFunChain "Lorg_eolang_dataized" obj = - evaluateUnaryDataizationFunChain id id wrapBytesInBytes (extractLabel "target") id obj -evaluateBuiltinFunChain "Lorg_eolang_error" obj = evaluateUnaryDataizationFunChain stringToBytes bytesToString wrapBytesInBytes (extractLabel "message") error obj --- evaluateBuiltinFunChain "Lorg_eolang_seq" obj = _ -- TODO --- evaluateBuiltinFunChain "Lorg_eolang_as_phi" obj = _ -- TODO --- evaluateBuiltinFunChain "Lorg_eolang_rust" obj = _ -- TODO --- evaluateBuiltinFunChain "Lorg_eolang_try" obj = _ -- TODO +evaluateBuiltinFunChain name@"Lorg_eolang_dataized" obj = + evaluateUnaryDataizationFunChain name id id wrapBytesInBytes (extractLabel "target") id obj +evaluateBuiltinFunChain name@"Lorg_eolang_error" obj = evaluateUnaryDataizationFunChain name stringToBytes bytesToString wrapBytesInBytes (extractLabel "message") error obj +-- evaluateBuiltinFunChain name@"Lorg_eolang_seq" obj = _ -- TODO +-- evaluateBuiltinFunChain name@"Lorg_eolang_as_phi" obj = _ -- TODO +-- evaluateBuiltinFunChain name@"Lorg_eolang_rust" obj = _ -- TODO +-- evaluateBuiltinFunChain name@"Lorg_eolang_try" obj = _ -- TODO evaluateBuiltinFunChain "Package" obj@(Formation bindings) = do \state -> do fmap dataizePackage getContext >>= \case diff --git a/src/Language/EO/Phi/Report/Html.hs b/src/Language/EO/Phi/Report/Html.hs --- a/src/Language/EO/Phi/Report/Html.hs +++ b/src/Language/EO/Phi/Report/Html.hs @@ -32,6 +32,7 @@ import Text.Blaze.Html5.Attributes (charset, class_, colspan, content, id, lang, onclick, type_, value) import Text.Blaze.Html5.Attributes qualified as TBHA import Prelude hiding (div, id, span) +import Prelude qualified -- $setup -- >>> import Text.Blaze.Html.Renderer.String (renderHtml) @@ -139,11 +140,11 @@ toHtmlReport :: ReportFormat -> PipelineConfig -> Report -> Html toHtmlReport reportFormat pipelineConfig report = toHtml - [ docType - , TBH.html ! lang "en-US" $ + [ memptyIfMarkdown docType + , idIfMarkdown (TBH.html ! lang "en-US") $ toHtml - [ TBH.head $ - toHtml $ + [ idIfMarkdown TBH.head $ + memptyIfMarkdown . toHtml $ [ meta ! charset "utf-8" , meta ! TBHA.name "viewport" ! content "width=device-width, initial-scale=1.0" , TBH.title "Report" @@ -166,94 +167,96 @@ }} |] ] - <> case reportFormat of - ReportFormat'Html -> - catMaybes - [ pipelineConfig.report.input >>= (.js) >>= \js -> pure (script $ toHtml js) - , pipelineConfig.report.input >>= (.css) >>= \css -> pure (style ! type_ "text/css" $ toHtml css) - ] - ReportFormat'Markdown -> [] - , body $ - toHtml $ - [ h2 "Overview" - <> p + <> catMaybes + [ pipelineConfig.report.input >>= (.js) >>= \js -> pure (script $ toHtml js) + , pipelineConfig.report.input >>= (.css) >>= \css -> pure (style ! type_ "text/css" $ toHtml css) + ] + , idIfMarkdown body $ + toHtml . (toHtml <$>) $ + [ + [ h2 "Overview" + , p [fmt| We translate EO files into initial PHI programs. Next, we normalize these programs and get normalized PHI programs. Then, we collect metrics for initial and normalized PHI programs. |] - <> h2 "Metrics" - <> p + , h2 "Metrics" + , p [fmt| An EO file contains multiple test objects. After translation, these test objects become attributes in PHI programs. We call these attributes "tests". |] - <> p + , p [fmt| We collect metrics on the number of {intercalate ", " (toListMetrics metricsNames)} in tests. We want normalized tests to have less such elements than initial tests do. |] - <> p "A metric change for a test is calculated by the formula" - <> p (code "(metric_initial - metric_normalized) / metric_initial") - <> p "where:" - <> ul + , p "A metric change for a test is calculated by the formula" + , p (code "(metric_initial - metric_normalized) / metric_initial") + , p "where:" + , ul ( toHtml [ li $ code "metric_initial" <> " is the metric for the initial test" , li $ code "metric_normalized" <> " is the metric for the normalized test" ] ) - <> h3 "Expected" - <> p [fmt|Metric changes are expected to be as follows or greater:|] - <> ul + , h3 "Expected" + , p [fmt|Metric changes are expected to be as follows or greater:|] + , ul ( toHtml . toListMetrics $ mkPercentItem <$> metricsNames <*> pipelineConfig.report.expectedMetricsChange ) - <> p + , p ( let expectedImprovedProgramsPercentage = pipelineConfig.report.expectedImprovedProgramsPercentage in [fmt|We expect such changes for at least {expectedImprovedProgramsPercentage:s} of tests.|] ) - <> h3 "Actual" - <> p [fmt|We normalized {testsCount} tests.|] - <> p [fmt|All metrics were improved for {mkNumber allGoodMetricsCount testsCount} tests.|] - <> p [fmt|Tests where a particular metric was improved:|] - <> ul + , h3 "Actual" + , p [fmt|We normalized {testsCount} tests.|] + , p [fmt|All metrics were improved for {mkNumber allGoodMetricsCount testsCount} tests.|] + , p [fmt|Tests where a particular metric was improved:|] + , ul ( toHtml . toListMetrics $ mkItem' <$> metricsNames <*> particularMetricsChangeGoodCount ) - <> h2 "Table" - <> p [fmt|The table below provides detailed information about tests.|] - ] - <> [ (TBH.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 + , h2 "Table" + , p [fmt|The table below provides detailed information about tests.|] + ] + , memptyIfMarkdown + [ TBH.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 - [ toHtmlReportTableHeader - , tbody . toHtml $ - uncurry (toHtmlReportRow reportFormat) - <$> zip [1 ..] (concat [programReport.bindingsRows | programReport <- report.programReports]) - ] - ] + , p "Click on the triangle to change the sorting order in the corresponding column." + ] + , + [ table ! class_ "sortable" ! id "table" $ + toHtml + [ toHtmlReportTableHeader + , tbody . toHtml $ + uncurry (toHtmlReportRow reportFormat) + <$> zip [1 ..] (concat [programReport.bindingsRows | programReport <- report.programReports]) + ] + ] + ] ] ] where isMarkdown = reportFormat == ReportFormat'Markdown + idIfMarkdown f = if isMarkdown then Prelude.id else f + memptyIfMarkdown f = if isMarkdown then mempty else f tests = concatMap (.bindingsRows) report.programReports diff --git a/src/Language/EO/Phi/Rules/Common.hs b/src/Language/EO/Phi/Rules/Common.hs --- a/src/Language/EO/Phi/Rules/Common.hs +++ b/src/Language/EO/Phi/Rules/Common.hs @@ -13,6 +13,7 @@ import Control.Applicative (Alternative ((<|>)), asum) import Control.Arrow (Arrow (first)) import Control.Monad +import Data.ByteString (ByteString) import Data.ByteString qualified as ByteString.Strict import Data.Char (toUpper) import Data.List (intercalate, minimumBy, nubBy, sortOn) @@ -21,6 +22,8 @@ import Data.Ord (comparing) import Data.Serialize qualified as Serialize import Data.String (IsString (..)) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text import Language.EO.Phi.Syntax.Abs import Language.EO.Phi.Syntax.Lex (Token) import Language.EO.Phi.Syntax.Par @@ -507,12 +510,12 @@ -- | Convert 'Bool' to 'Bytes'. -- -- >>> boolToBytes False --- Bytes "00-00-00-00-00-00-00-00" +-- Bytes "00-" -- >>> boolToBytes True --- Bytes "00-00-00-00-00-00-00-01" +-- Bytes "01-" boolToBytes :: Bool -> Bytes -boolToBytes True = intToBytes 1 -boolToBytes False = intToBytes 0 +boolToBytes True = Bytes "01-" +boolToBytes False = Bytes "00-" -- | Interpret 'Bytes' as 'Bool'. -- @@ -544,19 +547,29 @@ -- Bytes "48-65-6C-6C-6F-2C-20-77-6F-72-6C-64-21" -- -- >>> stringToBytes "Привет, мир!" --- Bytes "04-1F-44-04-38-43-24-35-44-22-C2-04-3C-43-84-40-21" +-- Bytes "D0-9F-D1-80-D0-B8-D0-B2-D0-B5-D1-82-2C-20-D0-BC-D0-B8-D1-80-21" +-- +-- >>> stringToBytes "hello, 大家!" +-- Bytes "68-65-6C-6C-6F-2C-20-E5-A4-A7-E5-AE-B6-21" stringToBytes :: String -> Bytes -stringToBytes s = Bytes $ normalizeBytes $ foldMap (padLeft 2 . (`showHex` "") . fromEnum) s +stringToBytes s = bytestringToBytes $ Text.encodeUtf8 (Text.pack s) +bytestringToBytes :: ByteString -> Bytes +bytestringToBytes = Bytes . normalizeBytes . foldMap (padLeft 2 . (`showHex` "")) . ByteString.Strict.unpack + +bytesToByteString :: Bytes -> ByteString +bytesToByteString (Bytes bytes) = ByteString.Strict.pack (go (filter (/= '-') bytes)) + where + go [] = [] + go (x : y : xs) = fst (head (readHex [x, y])) : go xs + go [_] = error "impossible: partial byte" + -- | Decode 'String' from 'Bytes'. -- -- >>> bytesToString "48-65-6C-6C-6F-2C-20-77-6F-72-6C-64-21" -- "Hello, world!" bytesToString :: Bytes -> String -bytesToString (Bytes bytes) = map (toEnum . fst . head . readHex) $ words (map dashToSpace bytes) - where - dashToSpace '-' = ' ' - dashToSpace c = c +bytesToString = Text.unpack . Text.decodeUtf8 . bytesToByteString -- | Encode 'Double' as 'Bytes' following IEEE754. -- diff --git a/src/Language/EO/Phi/Rules/Fast.hs b/src/Language/EO/Phi/Rules/Fast.hs --- a/src/Language/EO/Phi/Rules/Fast.hs +++ b/src/Language/EO/Phi/Rules/Fast.hs @@ -3,8 +3,6 @@ module Language.EO.Phi.Rules.Fast where --- import Debug.Trace (trace) - import Data.List.NonEmpty qualified as NonEmpty import Language.EO.Phi.Rules.Common import Language.EO.Phi.Rules.Yaml qualified as Yaml @@ -78,6 +76,10 @@ fastYegorInsideOutAsRule :: NamedRule fastYegorInsideOutAsRule = ("Yegor's rules (hardcoded)", \ctx obj -> [fastYegorInsideOut ctx obj]) +fastYegorInsideOutBinding :: Context -> Binding -> Binding +fastYegorInsideOutBinding ctx (AlphaBinding a obj) = AlphaBinding a (fastYegorInsideOut ctx obj) +fastYegorInsideOutBinding _ binding = binding + fastYegorInsideOut :: Context -> Object -> Object fastYegorInsideOut ctx = \case root | insideSubObject ctx -> root -- this rule is only applied at root @@ -97,20 +99,38 @@ Nothing -> case lookupBinding Phi bindings of Just objPhi -> fastYegorInsideOut ctx (ObjectDispatch (Yaml.substThis this objPhi) a) - Nothing -> ObjectDispatch this a + Nothing + | not (any isLambdaBinding bindings) -> Termination + | otherwise -> ObjectDispatch this a this -> ObjectDispatch this a Application obj argBindings -> case fastYegorInsideOut ctx obj of - obj'@(Formation bindings) -> - case argBindings of + obj'@(Formation bindings) -> do + let argBindings' = map (fastYegorInsideOutBinding ctx) argBindings + case argBindings' of + [AlphaBinding (Alpha "α0") arg0, AlphaBinding (Alpha "α1") arg1, AlphaBinding (Alpha "α2") arg2] -> + case filter isEmptyBinding bindings of + EmptyBinding a0 : EmptyBinding a1 : EmptyBinding a2 : _ -> + Formation + ( AlphaBinding a0 arg0 + : AlphaBinding a1 arg1 + : AlphaBinding a2 arg2 + : [ binding + | binding <- bindings + , case binding of + EmptyBinding x | x `elem` [a0, a1, a2] -> False + _ -> True + ] + ) + _ + | not (any isLambdaBinding bindings) -> Termination + | otherwise -> Application obj' argBindings' [AlphaBinding (Alpha "α0") arg0, AlphaBinding (Alpha "α1") arg1] -> case filter isEmptyBinding bindings of - EmptyBinding a0 : EmptyBinding a1 : _ -> do - let arg0' = fastYegorInsideOut ctx arg0 - let arg1' = fastYegorInsideOut ctx arg1 + EmptyBinding a0 : EmptyBinding a1 : _ -> Formation - ( AlphaBinding a0 arg0' - : AlphaBinding a1 arg1' + ( AlphaBinding a0 arg0 + : AlphaBinding a1 arg1 : [ binding | binding <- bindings , case binding of @@ -118,13 +138,14 @@ _ -> True ] ) - _ -> Application obj' argBindings + _ + | not (any isLambdaBinding bindings) -> Termination + | otherwise -> Application obj' argBindings' [AlphaBinding (Alpha "α0") arg0] -> case filter isEmptyBinding bindings of - EmptyBinding a0 : _ -> do - let arg0' = fastYegorInsideOut ctx arg0 + EmptyBinding a0 : _ -> Formation - ( AlphaBinding a0 arg0' + ( AlphaBinding a0 arg0 : [ binding | binding <- bindings , case binding of @@ -132,30 +153,35 @@ _ -> True ] ) - _ -> Application obj' argBindings - [AlphaBinding a argA] -> do - let argA' = fastYegorInsideOut ctx argA - Formation - ( AlphaBinding a argA' - : [ binding - | binding <- bindings - , case binding of - EmptyBinding x | x == a -> False - _ -> True - ] - ) - [DeltaBinding bytes] -> do - Formation - ( DeltaBinding bytes - : [ binding - | binding <- bindings - , case binding of - DeltaEmptyBinding -> False - _ -> True - ] - ) - _ -> Application obj' argBindings - obj' -> Application obj' argBindings + _ + | not (any isLambdaBinding bindings) -> Termination + | otherwise -> Application obj' argBindings' + [AlphaBinding a argA] + | EmptyBinding a `elem` bindings -> + Formation + ( AlphaBinding a argA + : [ binding + | binding <- bindings + , case binding of + EmptyBinding x | x == a -> False + _ -> True + ] + ) + | not (any isLambdaBinding bindings) -> Termination + [DeltaBinding bytes] + | DeltaEmptyBinding `elem` bindings -> do + Formation + ( DeltaBinding bytes + : [ binding + | binding <- bindings + , case binding of + DeltaEmptyBinding -> False + _ -> True + ] + ) + | not (any isLambdaBinding bindings) -> Termination + _ -> Application obj' argBindings' + obj' -> Application obj' (map (fastYegorInsideOutBinding ctx) argBindings) root@(Formation bindings) | any isEmptyBinding bindings || any isLambdaBinding bindings -> root | otherwise -> diff --git a/src/Language/EO/Phi/Syntax.hs b/src/Language/EO/Phi/Syntax.hs --- a/src/Language/EO/Phi/Syntax.hs +++ b/src/Language/EO/Phi/Syntax.hs @@ -41,9 +41,12 @@ rend i p = \case "[" : ts -> char '[' . rend i False ts "(" : ts -> char '(' . rend i False ts - -- "{" :ts -> onNewLine i p . showChar '{' . new (i+1) ts - -- "}" : ";":ts -> onNewLine (i-1) p . showString "};" . new (i-1) ts - -- "}" :ts -> onNewLine (i-1) p . showChar '}' . new (i-1) ts + "{" : "⟦" : ts -> showString "{⟦" . new (i + 1) ts + "⟦" : ts -> showChar '⟦' . new (i + 1) ts + ")" : "," : ts -> showString ")," . new i ts + "⟧" : "," : ts -> onNewLine (i - 1) p . showString "⟧," . new (i - 1) ts + ["⟧", "}"] -> onNewLine (i - 1) p . showString "⟧}" + "⟧" : ts -> onNewLine (i - 1) p . showChar '⟧' . new (i - 1) ts [";"] -> char ';' ";" : ts -> char ';' . new i ts t : ts@(s : _) @@ -85,3 +88,7 @@ closerOrPunct :: String closerOrPunct = ")],;" + + -- Make sure we are on a fresh line. + onNewLine :: Int -> Bool -> ShowS + onNewLine i p = (if p then id else showChar '\n') . indent i