eo-phi-normalizer 0.4.0 → 0.4.1
raw patch · 8 files changed
+317/−175 lines, 8 files
Files
- CHANGELOG.md +32/−0
- app/Main.hs +52/−2
- eo-phi-normalizer.cabal +1/−1
- src/Language/EO/Phi/Dataize.hs +82/−71
- src/Language/EO/Phi/Report/Html.hs +53/−50
- src/Language/EO/Phi/Rules/Common.hs +23/−10
- src/Language/EO/Phi/Rules/Fast.hs +64/−38
- src/Language/EO/Phi/Syntax.hs +10/−3
CHANGELOG.md view
@@ -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 <https://github.com/objectionary/eo/issues/3213#issuecomment-2150032168>+ - 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).
app/Main.hs view
@@ -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
eo-phi-normalizer.cabal view
@@ -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 <https://github.com/objectionary/eo-phi-normalizer#readme> homepage: https://github.com/objectionary/eo-phi-normalizer#readme
src/Language/EO/Phi/Dataize.hs view
@@ -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
src/Language/EO/Phi/Report/Html.hs view
@@ -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
src/Language/EO/Phi/Rules/Common.hs view
@@ -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. --
src/Language/EO/Phi/Rules/Fast.hs view
@@ -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 ->
src/Language/EO/Phi/Syntax.hs view
@@ -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