{- FOURMOLU_DISABLE -}
-- The MIT License (MIT)

-- Copyright (c) 2016-2024 Objectionary.com

-- Permission is hereby granted, free of charge, to any person obtaining a copy
-- of this software and associated documentation files (the "Software"), to deal
-- in the Software without restriction, including without limitation the rights
-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the Software is
-- furnished to do so, subject to the following conditions:

-- The above copyright notice and this permission notice shall be included
-- in all copies or substantial portions of the Software.

-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-- FITNESS FOR A PARTICULAR PURPOSE AND NON-INFRINGEMENT. IN NO EVENT SHALL THE
-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-- SOFTWARE.
{- FOURMOLU_ENABLE -}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}

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

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

import Data.Generics.Labels ()
import GHC.Generics (Generic)
import Language.EO.Phi.Rules.Common (lookupBinding, objectBindings)
import Language.EO.Phi.Syntax.Abs

data Context = Context
  { Context -> [Binding]
globalObject :: [Binding]
  , Context -> [Binding]
thisObject :: [Binding]
  }
  deriving ((forall x. Context -> Rep Context x)
-> (forall x. Rep Context x -> Context) -> Generic Context
forall x. Rep Context x -> Context
forall x. Context -> Rep Context x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Context -> Rep Context x
from :: forall x. Context -> Rep Context x
$cto :: forall x. Rep Context x -> Context
to :: forall x. Rep Context x -> Context
Generic)

-- | Normalize an input 𝜑-program.
normalize :: Program -> Program
normalize :: Program -> Program
normalize (Program [Binding]
bindings) = State Context Program -> Context -> Program
forall s a. State s a -> s -> a
evalState ([Binding] -> Program
Program ([Binding] -> Program)
-> (Object -> [Binding]) -> Object -> Program
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [Binding]
objectBindings (Object -> Program)
-> StateT Context Identity Object -> State Context Program
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> StateT Context Identity Object
normalizeObject ([Binding] -> Object
Formation [Binding]
bindings)) Context
context
 where
  context :: Context
context =
    Context
      { globalObject :: [Binding]
globalObject = [Binding]
bindings
      , thisObject :: [Binding]
thisObject = [Binding]
bindings
      }

normalizeObject :: Object -> State Context Object
normalizeObject :: Object -> StateT Context Identity Object
normalizeObject Object
object = do
  [Binding]
this <- (Context -> [Binding]) -> StateT Context Identity [Binding]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Context -> [Binding]
thisObject
  case Object
object of
    ObjectDispatch Object
ThisObject Attribute
a -> Object -> StateT Context Identity Object
forall a. a -> StateT Context Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> StateT Context Identity Object)
-> Object -> StateT Context Identity Object
forall a b. (a -> b) -> a -> b
$ Object -> Maybe Object -> Object
forall a. a -> Maybe a -> a
fromMaybe Object
object (Attribute -> [Binding] -> Maybe Object
lookupBinding Attribute
a [Binding]
this)
    Object
_ -> Object -> StateT Context Identity Object
forall a. a -> StateT Context Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Object
object

-- | Split compound object into its head and applications/dispatch actions.
peelObject :: Object -> PeeledObject
peelObject :: Object -> PeeledObject
peelObject = \case
  Formation [Binding]
bindings -> ObjectHead -> [ObjectAction] -> PeeledObject
PeeledObject ([Binding] -> ObjectHead
HeadFormation [Binding]
bindings) []
  Application Object
object [Binding]
bindings -> Object -> PeeledObject
peelObject Object
object PeeledObject -> ObjectAction -> PeeledObject
`followedBy` [Binding] -> ObjectAction
ActionApplication [Binding]
bindings
  ObjectDispatch Object
object Attribute
attr -> Object -> PeeledObject
peelObject Object
object PeeledObject -> ObjectAction -> PeeledObject
`followedBy` Attribute -> ObjectAction
ActionDispatch Attribute
attr
  Object
GlobalObject -> ObjectHead -> [ObjectAction] -> PeeledObject
PeeledObject ObjectHead
HeadGlobal []
  Object
ThisObject -> ObjectHead -> [ObjectAction] -> PeeledObject
PeeledObject ObjectHead
HeadThis []
  Object
Termination -> ObjectHead -> [ObjectAction] -> PeeledObject
PeeledObject ObjectHead
HeadTermination []
  MetaObject ObjectMetaId
_ -> ObjectHead -> [ObjectAction] -> PeeledObject
PeeledObject ObjectHead
HeadTermination []
  MetaTailContext{} -> [Char] -> PeeledObject
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"
  MetaFunction MetaFunctionName
_ Object
_ -> [Char] -> PeeledObject
forall a. HasCallStack => [Char] -> a
error [Char]
"To be honest, I'm not sure what should be here"
  MetaSubstThis{} -> [Char] -> PeeledObject
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"
  MetaContextualize{} -> [Char] -> PeeledObject
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"
 where
  followedBy :: PeeledObject -> ObjectAction -> PeeledObject
followedBy (PeeledObject ObjectHead
object [ObjectAction]
actions) ObjectAction
action = ObjectHead -> [ObjectAction] -> PeeledObject
PeeledObject ObjectHead
object ([ObjectAction]
actions [ObjectAction] -> [ObjectAction] -> [ObjectAction]
forall a. [a] -> [a] -> [a]
++ [ObjectAction
action])

unpeelObject :: PeeledObject -> Object
unpeelObject :: PeeledObject -> Object
unpeelObject (PeeledObject ObjectHead
head_ [ObjectAction]
actions) =
  case ObjectHead
head_ of
    HeadFormation [Binding]
bindings -> Object -> [ObjectAction] -> Object
go ([Binding] -> Object
Formation [Binding]
bindings) [ObjectAction]
actions
    ObjectHead
HeadGlobal ->
      case [ObjectAction]
actions of
        ActionApplication{} : [ObjectAction]
_ -> [Char] -> Object
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible: application for a global object!"
        [ObjectAction]
_ -> Object -> [ObjectAction] -> Object
go Object
GlobalObject [ObjectAction]
actions
    ObjectHead
HeadThis ->
      case [ObjectAction]
actions of
        ActionApplication{} : [ObjectAction]
_ -> [Char] -> Object
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible: application for a global object!"
        [ObjectAction]
_ -> Object -> [ObjectAction] -> Object
go Object
ThisObject [ObjectAction]
actions
    ObjectHead
HeadTermination -> Object -> [ObjectAction] -> Object
go Object
Termination [ObjectAction]
actions
 where
  go :: Object -> [ObjectAction] -> Object
go = (Object -> ObjectAction -> Object)
-> Object -> [ObjectAction] -> Object
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Object -> ObjectAction -> Object
applyAction
  applyAction :: Object -> ObjectAction -> Object
applyAction Object
object = \case
    ActionDispatch Attribute
attr -> Object -> Attribute -> Object
ObjectDispatch Object
object Attribute
attr
    ActionApplication [Binding]
bindings -> Object -> [Binding] -> Object
Application Object
object [Binding]
bindings