phino-0.0.81: test/DataizeSpec.hs
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com
-- SPDX-License-Identifier: MIT
module DataizeSpec (spec) where
import AST
import Control.Monad
import Data.List (nub)
import Data.List.NonEmpty (NonEmpty (..))
import Dataize (DataizeContext (DataizeContext), dataize, dataize', execBuildTerm, morph)
import Deps (Term (TeExpression), dontSaveStep)
import Functions (buildTerm)
import Matcher (substEmpty)
import Parser (parseExpressionThrows, parseProgramThrows)
import Rewriter (Rewritten)
import Test.Hspec
import Yaml qualified
defaultDataizeContext :: Expression -> Program -> DataizeContext
defaultDataizeContext loc prog = DataizeContext loc prog 25 25 False buildTerm dontSaveStep
test :: (Eq a, Show a) => ((Expression, NonEmpty Rewritten) -> DataizeContext -> IO (Maybe a, [Rewritten])) -> [(String, Expression, Expression, Maybe a)] -> Spec
test func useCases =
forM_ useCases $ \(desc, input, expr, output) ->
it desc $ do
let prog = Program expr
(res, _) <- func (input, (prog, Nothing) :| []) (defaultDataizeContext ExRoot prog)
res `shouldBe` output
test' :: (Eq a, Show a) => ((Expression, NonEmpty Rewritten) -> DataizeContext -> IO (a, NonEmpty Rewritten)) -> [(String, Expression, Expression, a)] -> Spec
test' func useCases =
forM_ useCases $ \(desc, input, expr, output) ->
it desc $ do
let prog = Program expr
(res, _) <- func (input, (prog, Nothing) :| []) (defaultDataizeContext ExRoot prog)
res `shouldBe` output
testDataize :: [(String, String, String, Bytes)] -> Spec
testDataize useCases =
forM_ useCases $ \(name, loc, prog, res) ->
it name $ do
prog' <- parseProgramThrows prog
loc' <- parseExpressionThrows loc
(value, _) <- dataize (defaultDataizeContext loc' prog')
value `shouldBe` Just res
spec :: Spec
spec = do
describe "morph" $
test'
morph
[ ("[[ D> 00- ]] => [[ D> 00- ]]", ExFormation [BiDelta (BtOne "00")], ExRoot, ExFormation [BiDelta (BtOne "00")])
, ("T => T", ExTermination, ExRoot, ExTermination)
, ("$ => X", ExXi, ExRoot, ExTermination)
, ("Q => X", ExRoot, ExRoot, ExTermination)
,
( "Q.x (Q -> [[ x -> [[]] ]]) => [[]]"
, ExDispatch ExRoot (AtLabel "x")
, ExFormation [BiTau (AtLabel "x") (ExFormation [])]
, ExFormation []
)
]
describe "dataize" $
test
dataize'
[ ("[[ D> 00- ]] => 00-", ExFormation [BiDelta (BtOne "00")], ExRoot, Just (BtOne "00"))
, ("T => X", ExTermination, ExRoot, Nothing)
,
( "[[ @ -> [[ D> 00-]] ]] => 00-"
, ExFormation [BiTau AtPhi (ExFormation [BiDelta (BtOne "00"), BiVoid AtRho]), BiVoid AtRho]
, ExRoot
, Just (BtOne "00")
)
,
( "[[ @ -> [[ x -> [[ D> 01-, y -> ? ]](y -> [[ ]]) ]].x ]] => 01-"
, ExFormation
[ BiTau
AtPhi
( ExDispatch
( ExFormation
[ BiTau
(AtLabel "x")
( ExApplication
( ExFormation
[ BiDelta (BtOne "01")
, BiVoid (AtLabel "y")
, BiVoid AtRho
]
)
(ArTau (AtLabel "y") (ExFormation []))
)
]
)
(AtLabel "x")
)
]
, ExRoot
, Just (BtOne "01")
)
]
describe "execBuildTerm" $
it "resolves global dispatch from the universe Q" $ do
prog <- parseProgramThrows "Q -> [[ x -> [[ D> 42- ]] ]]"
expected <- parseExpressionThrows "[[ D> 42- ]]"
term <- execBuildTerm (defaultDataizeContext ExRoot prog) "global" [Yaml.ArgAttribute (AtLabel "x")] substEmpty
case term of
TeExpression actual -> actual `shouldBe` expected
_ -> expectationFailure "global() did not return an expression"
describe "labels every step with a defined rule or operation" $ do
let funcs = maybe [] (map Yaml.function)
allowed =
map (.name) Yaml.morphingRules
++ map (.name) Yaml.dataizationRules
++ map (.name) Yaml.normalizationRules
++ concatMap (funcs . (.where_)) Yaml.morphingRules
++ concatMap (funcs . (.where_)) Yaml.dataizationRules
it "uses no step label without a defining rule or operation" $ do
prog <-
parseProgramThrows
( unlines
[ "Q -> [["
, " bytes(data) -> [[ @ -> $.data ]],"
, " number(as-bytes) -> [[ @ -> $.as-bytes, plus(x) -> [[ L> L_number_plus ]] ]],"
, " @ -> 5.plus(6)"
, "]]"
]
)
loc <- parseExpressionThrows "Q"
(_, chain) <- dataize (defaultDataizeContext loc prog)
let orphans = nub [label | (_, Just label) <- chain, label `notElem` allowed]
unless
(null orphans)
(expectationFailure ("Dataization emitted step labels with no defining rule or operation: " ++ show orphans))
describe "names every rule uniquely across rule sets" $
it "shares no rule name between morphing, dataization and normalization" $ do
let names =
map (.name) Yaml.morphingRules
++ map (.name) Yaml.dataizationRules
++ map (.name) Yaml.normalizationRules
clashes = nub (filter (\n -> length (filter (== n) names) > 1) names)
clashes `shouldBe` []
describe "preserves the reduction label sequence" $ do
let labelsOf loc src = do
prog <- parseProgramThrows src
loc' <- parseExpressionThrows loc
(_, chain) <- dataize (defaultDataizeContext loc' prog)
pure [label | (_, Just label) <- chain]
it "dataizes 5.plus(6) through the expected rules" $ do
labels <-
labelsOf
"Q"
"Q -> [[ bytes(data) -> [[ @ -> $.data ]], number(as-bytes) -> [[ @ -> $.as-bytes, plus(x) -> [[ L> L_number_plus ]] ]], @ -> 5.plus(6) ]]"
labels
`shouldBe` [ "contextualize"
, "root"
, "alpha"
, "copy"
, "dot"
, "copy"
, "alpha"
, "copy"
, "lambda"
, "root"
, "alpha"
, "copy"
, "prim"
, "contextualize"
, "dot"
, "root"
, "alpha"
, "copy"
, "copy"
, "prim"
, "contextualize"
, "dot"
, "copy"
]
it "dataizes a located reference through the expected rules" $ do
labels <- labelsOf "Q.foo.bar" "Q -> [[ foo -> [[ bar -> [[ @ -> Q.x ]] ]], x -> [[ D> 42- ]] ]]"
labels `shouldBe` ["contextualize", "root", "prim"]
testDataize
[
( "5.plus(6)"
, "Q"
, unlines
[ "Q -> [["
, " bytes(data) -> [["
, " @ -> $.data"
, " ]],"
, " number(as-bytes) -> [["
, " @ -> $.as-bytes,"
, " plus(x) -> [[ L> L_number_plus ]]"
, " ]],"
, " @ -> 5.plus(6)"
, "]]"
]
, BtMany ["40", "26", "00", "00", "00", "00", "00", "00"]
)
,
( "Fahrenheit"
, "Q"
, unlines
[ "Q -> [["
, " bytes -> [["
, " data -> ?,"
, " @ -> $.data"
, " ]],"
, " number -> [["
, " as-bytes -> ?,"
, " @ -> $.as-bytes,"
, " plus -> [[ x -> ?, L> L_number_plus ]],"
, " times -> [[ x -> ?, L> L_number_times ]]"
, " ]],"
, " @ -> $.c.times(1.8).plus(32),"
, " c -> 25"
, "]]"
]
, BtMany ["40", "53", "40", "00", "00", "00", "00", "00"]
)
,
( "Factorial"
, "Q"
, unlines
[ "Q -> [["
, " bytes -> [["
, " data -> ?,"
, " @ -> $.data"
, " ]],"
, " number -> [["
, " as-bytes -> ?,"
, " @ -> $.as-bytes,"
, " times -> [[ x -> ?, L> L_number_times ]],"
, " plus -> [[ x -> ?, L> L_number_plus ]],"
, " eq -> [[ x -> ?, y -> ?, L> L_number_eq ]]"
, " ]],"
, " fac -> [["
, " x -> ?,"
, " @ -> $.x.eq("
, " 1,"
, " $.x.times($.^.fac($.x.plus(-1)))"
, " )"
, " ]],"
, " @ -> $.fac(3)"
, "]]"
]
, BtMany ["40", "18", "00", "00", "00", "00", "00", "00"]
)
,
( "Located"
, "Q.foo.bar"
, unlines
[ "Q -> [["
, " foo -> [["
, " bar -> [["
, " @ -> Q.x"
, " ]]"
, " ]],"
, " x -> [[ D> 42- ]]"
, "]]"
]
, BtOne "42"
)
,
( "Five"
, "Q.x"
, unlines
[ "Q -> [["
, " number(as-bytes) -> [[ @ -> as-bytes ]],"
, " bytes(data) -> [[ @ -> data ]],"
, " x -> 5"
, "]]"
]
, BtMany ["40", "14", "00", "00", "00", "00", "00", "00"]
)
]