ObserveSharing.hs

{-# 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.Eq (Eq(..))
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 :: ObserveSharing TH.Name repr a -> repr a
observeSharing = Letable.observeSharing

-- | Needed by 'observeSharing'.
instance Hashable TH.Name where
  hashWithSalt s = hashWithSalt s . show

-- Combinators semantics for the 'ObserveSharing' interpreter.
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , Satisfiable tok repr
  ) => Satisfiable tok (ObserveSharing letName repr)
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , Alternable repr
  ) => Alternable (ObserveSharing letName repr)
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , Applicable repr
  ) => Applicable (ObserveSharing letName repr)
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , Selectable repr
  ) => Selectable (ObserveSharing letName repr)
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , Matchable repr
  ) => Matchable (ObserveSharing letName 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 letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , 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 letName repr)
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , Lookable repr
  ) => Lookable (ObserveSharing letName repr)

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