ObserveSharing.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.Parser.Grammar.ObserveSharing
  ( module Symantic.Typed.ObserveSharing
  , 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.Typed.Derive
import Symantic.Typed.ObserveSharing hiding (observeSharing)
import qualified Symantic.Typed.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 (Letable TH.Name repr, CombAlternable repr) =>
  CombAlternable (ObserveSharing TH.Name repr)
instance (Letable TH.Name repr, CombApplicable repr) =>
  CombApplicable (ObserveSharing TH.Name repr)
instance
  ( Letable TH.Name repr
  , CombFoldable repr
  {- TODO: the following constraints are for the current CombFoldable,
   - they will have to be removed when CombFoldable will have 'liftDerived2' as defaults
   -}
  , CombApplicable repr
  , CombAlternable repr
  ) => CombFoldable (ObserveSharing TH.Name repr)
instance (Letable TH.Name repr, CombLookable repr) =>
  CombLookable (ObserveSharing TH.Name repr)
instance (Letable TH.Name repr, CombMatchable repr) =>
  CombMatchable (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, CombSelectable repr) =>
  CombSelectable (ObserveSharing TH.Name repr)
instance (Letable TH.Name repr, CombSatisfiable tok repr) =>
  CombSatisfiable tok (ObserveSharing TH.Name repr)

-- 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) where
  chainPre = liftDerived2 chainPre
  chainPost = liftDerived2 chainPost
instance CombLookable repr => CombLookable (FinalizeSharing TH.Name repr)
instance CombMatchable repr => CombMatchable (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 CombSatisfiable tok repr => CombSatisfiable tok (FinalizeSharing TH.Name repr)
instance CombSelectable repr => CombSelectable (FinalizeSharing TH.Name repr)