Normalize.hs

{-# LANGUAGE LambdaCase #-}

module Language.EO.Phi.Normalize (
  normalizeObject,
  normalize,
  peelObject,
  unpeelObject,
) where

import Control.Monad.State
import Data.Maybe (fromMaybe)
import Numeric (showHex)

import Control.Monad (forM)
import Language.EO.Phi.Rules.Common (lookupBinding)
import Language.EO.Phi.Syntax.Abs

data Context = Context
  { globalObject :: [Binding]
  , thisObject :: [Binding]
  , totalNuCount :: Int
  }

isNu :: Binding -> Bool
isNu (AlphaBinding VTX _) = True
isNu (EmptyBinding VTX) = True
isNu _ = False

-- | Normalize an input 𝜑-program.
normalize :: Program -> Program
normalize (Program bindings) = evalState (Program . objectBindings <$> normalizeObject (Formation bindings)) context
 where
  context =
    Context
      { globalObject = bindings
      , thisObject = bindings
      , totalNuCount = nuCount bindings
      }
  nuCount binds = count isNu binds + sum (map (sum . map (nuCount . objectBindings) . values) binds)
  count = (length .) . filter
  values (AlphaBinding _ obj) = [obj]
  values _ = []
  objectBindings (Formation bs) = bs
  objectBindings _ = []

rule1 :: Object -> State Context Object
rule1 (Formation bindings) = do
  normalizedBindings <- forM bindings $ \case
    AlphaBinding a object
      | a /= VTX ->
          do
            object' <- rule1 object
            pure (AlphaBinding a object')
    b -> pure b
  finalBindings <-
    if not $ any isNu normalizedBindings
      then do
        nus <- gets totalNuCount
        modify (\c -> c{totalNuCount = totalNuCount c + 1})
        let pad s = (if even (length s) then "" else "0") ++ s
        let insertDashes s
              | length s <= 2 = s ++ "-"
              | otherwise =
                  let go = \case
                        [] -> []
                        [x] -> [x]
                        [x, y] -> [x, y, '-']
                        (x : y : xs) -> x : y : '-' : go xs
                   in go s
        let dataObject = Formation [DeltaBinding $ Bytes $ insertDashes $ pad $ showHex nus ""]
        pure (AlphaBinding VTX dataObject : normalizedBindings)
      else do
        pure normalizedBindings
  pure (Formation finalBindings)
rule1 object = pure object

normalizeObject :: Object -> State Context Object
normalizeObject object = do
  this <- gets thisObject
  case object of
    -- Rule 1
    obj@(Formation _) -> rule1 obj
    ThisDispatch a -> pure $ fromMaybe object (lookupBinding a this)
    _ -> pure object

-- | Split compound object into its head and applications/dispatch actions.
peelObject :: Object -> PeeledObject
peelObject = \case
  Formation bindings -> PeeledObject (HeadFormation bindings) []
  Application object bindings -> peelObject object `followedBy` ActionApplication bindings
  ObjectDispatch object attr -> peelObject object `followedBy` ActionDispatch attr
  GlobalDispatch attr -> PeeledObject HeadGlobal [ActionDispatch attr]
  ThisDispatch attr -> PeeledObject HeadThis [ActionDispatch attr]
  Termination -> PeeledObject HeadTermination []
  MetaObject _ -> PeeledObject HeadTermination []
 where
  followedBy (PeeledObject object actions) action = PeeledObject object (actions ++ [action])

unpeelObject :: PeeledObject -> Object
unpeelObject (PeeledObject head_ actions) =
  case head_ of
    HeadFormation bindings -> go (Formation bindings) actions
    HeadGlobal ->
      case actions of
        ActionDispatch a : as -> go (GlobalDispatch a) as
        _ -> error "impossible: global object without dispatch!"
    HeadThis ->
      case actions of
        ActionDispatch a : as -> go (ThisDispatch a) as
        _ -> error "impossible: this object without dispatch!"
    HeadTermination -> go Termination actions
 where
  go = foldl applyAction
  applyAction object = \case
    ActionDispatch attr -> ObjectDispatch object attr
    ActionApplication bindings -> Application object bindings