ObserveSharing.hs

{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.Parser.Grammar.ObserveSharing
  ( module Symantic.ObserveSharing
  , module Symantic.Parser.Grammar.ObserveSharing
  ) 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 F

import Symantic.Parser.Grammar.Combinators
import Symantic.Derive
import Symantic.ObserveSharing hiding (observeSharing)
import qualified Symantic.ObserveSharing as ObserveSharing
import qualified Language.Haskell.TH.Syntax as TH

-- | Like 'Observable.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) = ObserveSharing.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
  ( Referenceable TH.Name repr
  , CombAlternable repr
  ) => CombAlternable (ObserveSharing TH.Name repr)
instance
  ( Referenceable TH.Name repr
  , CombApplicable repr
  ) => CombApplicable (ObserveSharing TH.Name repr)
instance
  ( Referenceable TH.Name repr
  , CombFoldable repr
  ) => CombFoldable (ObserveSharing TH.Name repr)
instance
  ( Referenceable TH.Name repr
  , CombLookable repr
  ) => CombLookable (ObserveSharing TH.Name repr)
instance
  ( Referenceable TH.Name repr
  , CombMatchable repr
  ) => CombMatchable (ObserveSharing 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 'ObserveSharing' interpreter.
  conditional a bs d = observeSharingNode $ ObserveSharing $ conditional
    F.<$> unObserveSharing a
    F.<*> mapM (\(p, b) -> (p,) F.<$> unObserveSharing b) bs
    F.<*> unObserveSharing d
instance
  ( Referenceable TH.Name repr
  , CombSelectable repr
  ) => CombSelectable (ObserveSharing TH.Name repr)
instance
  ( Referenceable TH.Name repr
  , CombSatisfiable tok repr
  ) => CombSatisfiable tok (ObserveSharing TH.Name repr)
instance
  ( Referenceable TH.Name repr
  , CombRegisterableUnscoped repr
  ) => CombRegisterable (ObserveSharing TH.Name repr) where
  new ini f =
    -- 'unsafePerformIO' is used here because propagating 'IO'
    -- would prevent 'observeSharing' 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 x = putUnscoped (unRegister reg) x
instance
  ( Referenceable TH.Name repr
  , CombRegisterableUnscoped repr
  ) => CombRegisterableUnscoped (ObserveSharing TH.Name repr)

-- * Class 'CombRegisterableUnscoped'
-- | These combinators are used to remove the @Rank2Types@ from 'CombRegisterable'
-- in order to be able to 'observeSharing'.
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 'FinalizeSharing' interpreter.
instance
  ( CombApplicable repr
  ) => CombApplicable (FinalizeSharing TH.Name repr)
instance
  ( CombAlternable repr
  ) => CombAlternable (FinalizeSharing TH.Name repr)
instance
  ( CombFoldable repr
  ) => CombFoldable (FinalizeSharing TH.Name repr)
instance
  ( CombLookable repr
  ) => CombLookable (FinalizeSharing TH.Name repr)
instance
  ( CombMatchable repr
  ) => CombMatchable (FinalizeSharing TH.Name repr) where
  conditional a bs d = FinalizeSharing $ conditional
    F.<$> unFinalizeSharing a
    F.<*> mapM (\(p, b) -> (p,) F.<$> unFinalizeSharing b) bs
    F.<*> unFinalizeSharing d
instance
  ( CombSatisfiable tok repr
  ) => CombSatisfiable tok (FinalizeSharing TH.Name repr)
instance
  ( CombSelectable repr
  ) => CombSelectable (FinalizeSharing TH.Name repr)
instance
  ( CombRegisterableUnscoped repr
  ) => CombRegisterableUnscoped (FinalizeSharing 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]