{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.Parser.Grammar.ObserveSharing
  ( module Symantic.Univariant.Letable
  , module Symantic.Parser.Grammar.ObserveSharing
  ) where

import Control.Monad (mapM)
import Data.Function (($), (.))
import Data.Hashable (Hashable, hashWithSalt)
import Text.Show (Show(..))
import qualified Control.Applicative as Functor

import Symantic.Parser.Grammar.Combinators
import Symantic.Univariant.Letable hiding (observeSharing)
import qualified Symantic.Univariant.Letable as Letable
import qualified Language.Haskell.TH.Syntax as TH
import qualified Symantic.Univariant.Trans as Sym

-- | Like 'Letable.observeSharing'
-- but type-binding @(letName)@ to 'TH.Name'
-- to avoid the trouble to always set it.
observeSharing ::
  Letsable TH.Name repr =>
  ObserveSharing TH.Name repr a ->
  repr a
observeSharing os = lets defs body
  where (body, defs) = Letable.observeSharing os

-- | Needed by 'observeSharing'.
instance Hashable TH.Name where
  hashWithSalt s = hashWithSalt s . show
instance MakeLetName TH.Name where
  makeLetName _ = TH.qNewName "name"

-- Combinators semantics for the 'ObserveSharing' interpreter.
instance
  ( Letable TH.Name repr
  , Satisfiable tok repr
  ) => Satisfiable tok (ObserveSharing TH.Name repr)
instance
  ( Letable TH.Name repr
  , Alternable repr
  ) => Alternable (ObserveSharing TH.Name repr)
instance
  ( Letable TH.Name repr
  , Applicable repr
  ) => Applicable (ObserveSharing TH.Name repr)
instance
  ( Letable TH.Name repr
  , Selectable repr
  ) => Selectable (ObserveSharing TH.Name repr)
instance
  ( Letable TH.Name repr
  , Matchable repr
  ) => Matchable (ObserveSharing TH.Name repr) where
  -- Here the default definition does not fit
  -- since there is no lift* for the type of 'conditional'
  -- and its default definition does not handles 'bs'
  -- as needed by the 'ObserveSharing' transformation.
  conditional a cs bs b = observeSharingNode $ ObserveSharing $
    conditional
      Functor.<$> unObserveSharing a
      Functor.<*> Functor.pure cs
      Functor.<*> mapM unObserveSharing bs
      Functor.<*> unObserveSharing b
instance
  ( Letable TH.Name repr
  , Foldable repr
  {- TODO: the following constraints are for the current Foldable,
   - they will have to be removed when Foldable will have Sym.lift2 as defaults
   -}
  , Applicable repr
  , Alternable repr
  ) => Foldable (ObserveSharing TH.Name repr)
instance
  ( Letable TH.Name repr
  , Lookable repr
  ) => Lookable (ObserveSharing TH.Name repr)

-- Combinators semantics for the 'FinalizeSharing' interpreter.
instance Applicable repr => Applicable (FinalizeSharing TH.Name repr)
instance Alternable repr => Alternable (FinalizeSharing TH.Name repr)
instance Satisfiable tok repr => Satisfiable tok (FinalizeSharing TH.Name repr)
instance Selectable repr => Selectable (FinalizeSharing TH.Name repr)
instance Matchable repr => Matchable (FinalizeSharing TH.Name repr) where
  conditional a cs bs b = FinalizeSharing $
    conditional
      Functor.<$> unFinalizeSharing a
      Functor.<*> Functor.pure cs
      Functor.<*> mapM unFinalizeSharing bs
      Functor.<*> unFinalizeSharing b
instance Lookable repr => Lookable (FinalizeSharing TH.Name repr)
instance Foldable repr => Foldable (FinalizeSharing TH.Name repr) where
  chainPre = Sym.lift2 chainPre
  chainPost = Sym.lift2 chainPost