{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.Parser.Grammar.SharingObserver
  ( module Symantic.Semantics.SharingObserver
  , module Symantic.Parser.Grammar.SharingObserver
  ) where

import Control.Monad (mapM)
import Data.Function (($), (.))
import Data.Hashable (Hashable, hashWithSalt)
import System.IO.Unsafe (unsafePerformIO) -- For 'new'
import Text.Show (Show(..))
import qualified Control.Applicative as App

import Symantic.Parser.Grammar.Combinators
import Symantic.Syntaxes.Derive
import Symantic.Semantics.SharingObserver hiding (sharingObserver)
import qualified Symantic.Semantics.SharingObserver as SharingObserver
import qualified Language.Haskell.TH.Syntax as TH

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

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

-- Combinators semantics for the 'SharingObserver' interpreter.
instance
  ( Referenceable TH.Name repr
  , CombAlternable repr
  ) => CombAlternable (SharingObserver TH.Name repr)
instance
  ( Referenceable TH.Name repr
  , CombApplicable repr
  ) => CombApplicable (SharingObserver TH.Name repr)
instance
  ( Referenceable TH.Name repr
  , CombFoldable repr
  ) => CombFoldable (SharingObserver TH.Name repr)
instance
  ( Referenceable TH.Name repr
  , CombLookable repr
  ) => CombLookable (SharingObserver TH.Name repr)
instance
  ( Referenceable TH.Name repr
  , CombMatchable repr
  ) => CombMatchable (SharingObserver TH.Name repr) where
  -- Here the default definition does not fit
  -- since there is no liftDerived* for the type of 'conditional'
  -- and its default definition does not handles 'bs'
  -- as needed by the 'SharingObserver' interpreter.
  conditional a bs d = sharingObserverNode $ SharingObserver $ conditional
    App.<$> unSharingObserver a
    App.<*> mapM (\(p, b) -> (p,) App.<$> unSharingObserver b) bs
    App.<*> unSharingObserver d
instance
  ( Referenceable TH.Name repr
  , CombSelectable repr
  ) => CombSelectable (SharingObserver TH.Name repr)
instance
  ( Referenceable TH.Name repr
  , CombSatisfiable tok repr
  ) => CombSatisfiable tok (SharingObserver TH.Name repr)
instance
  ( Referenceable TH.Name repr
  , CombRegisterableUnscoped repr
  ) => CombRegisterable (SharingObserver TH.Name repr) where
  new ini f =
    -- 'unsafePerformIO' is used here because propagating 'IO'
    -- would prevent 'sharingObserver' to recognize recursive let,
    -- causing an infinite loop on them.
    let !regName = unsafePerformIO $ TH.newName "reg" in
    let reg = UnscopedRegister regName in
    newUnscoped reg ini (f (Register reg))
  get = getUnscoped . unRegister
  put reg = putUnscoped (unRegister reg)
instance
  ( Referenceable TH.Name repr
  , CombRegisterableUnscoped repr
  ) => CombRegisterableUnscoped (SharingObserver TH.Name repr)

-- * Class 'CombRegisterableUnscoped'
-- | These combinators are used to remove the @Rank2Types@ from 'CombRegisterable'
-- in order to be able to 'sharingObserver'.
class CombRegisterableUnscoped (repr::ReprComb) where
  newUnscoped :: UnscopedRegister a -> repr a -> repr b -> repr b
  getUnscoped :: UnscopedRegister a -> repr a
  putUnscoped :: UnscopedRegister a -> repr a -> repr ()
  default newUnscoped ::
    FromDerived2 CombRegisterableUnscoped repr =>
    UnscopedRegister a -> repr a -> repr b -> repr b
  default getUnscoped ::
    FromDerived CombRegisterableUnscoped repr =>
    UnscopedRegister a -> repr a
  default putUnscoped ::
    FromDerived1 CombRegisterableUnscoped repr =>
    UnscopedRegister a -> repr a -> repr ()
  newUnscoped = liftDerived2 . newUnscoped
  getUnscoped = liftDerived . getUnscoped
  putUnscoped = liftDerived1 . putUnscoped

-- Combinators semantics for the 'SharingFinalizer' interpreter.
instance
  ( CombApplicable repr
  ) => CombApplicable (SharingFinalizer TH.Name repr)
instance
  ( CombAlternable repr
  ) => CombAlternable (SharingFinalizer TH.Name repr)
instance
  ( CombFoldable repr
  ) => CombFoldable (SharingFinalizer TH.Name repr)
instance
  ( CombLookable repr
  ) => CombLookable (SharingFinalizer TH.Name repr)
instance
  ( CombMatchable repr
  ) => CombMatchable (SharingFinalizer TH.Name repr) where
  conditional a bs d = SharingFinalizer $ conditional
    App.<$> unSharingFinalizer a
    App.<*> mapM (\(p, b) -> (p,) App.<$> unSharingFinalizer b) bs
    App.<*> unSharingFinalizer d
instance
  ( CombSatisfiable tok repr
  ) => CombSatisfiable tok (SharingFinalizer TH.Name repr)
instance
  ( CombSelectable repr
  ) => CombSelectable (SharingFinalizer TH.Name repr)
instance
  ( CombRegisterableUnscoped repr
  ) => CombRegisterableUnscoped (SharingFinalizer TH.Name repr)

-- | Call trace stack updated by 'call' and 'refJoin'.
-- Used to avoid infinite loops when tying the knot with 'polyfix'.
type CallTrace = [TH.Name]