Dataize.hs

{-# 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, ())