ObserveSharing.hs

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

import Control.Monad (mapM)
import Control.Applicative (Applicative(..))
import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Hashable (Hashable, hashWithSalt)
import Text.Show (Show(..))

import Symantic.Univariant.Letable as Letable
import qualified Symantic.Univariant.Trans as Sym
import qualified Symantic.Parser.Grammar.Combinators as Comb
import qualified Language.Haskell.TH.Syntax as TH

-- | Like 'Letable.observeSharing'
-- but type-binding @(letName)@ to 'TH.Name' to help type inference.
observeSharing :: ObserveSharing TH.Name repr a -> repr a
observeSharing = Letable.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
  , Comb.Satisfiable repr tok
  ) => Comb.Satisfiable (ObserveSharing letName repr) tok
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , Comb.Alternable repr
  ) => Comb.Alternable (ObserveSharing letName repr)
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , Comb.Applicable repr
  ) => Comb.Applicable (ObserveSharing letName repr)
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , Comb.Selectable repr
  ) => Comb.Selectable (ObserveSharing letName repr)
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , Comb.Matchable repr
  ) => Comb.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 handles does not handles 'bs'
  -- as needed by the 'ObserveSharing' transformation.
  conditional cs bs a b = observeSharingNode $ ObserveSharing $
    Comb.conditional cs
      <$> mapM unObserveSharing bs
      <*> unObserveSharing a
      <*> unObserveSharing b
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , Comb.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
   -}
  , Comb.Applicable repr
  , Comb.Alternable repr
  ) => Comb.Foldable (ObserveSharing letName repr)
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , Comb.Lookable repr
  ) => Comb.Lookable (ObserveSharing letName repr)

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