{-# 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 G
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
  , G.Satisfiable repr tok
  ) => G.Satisfiable (ObserveSharing letName repr) tok
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , G.Alternable repr
  ) => G.Alternable (ObserveSharing letName repr)
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , G.Applicable repr
  ) => G.Applicable (ObserveSharing letName repr)
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , G.Selectable repr
  ) => G.Selectable (ObserveSharing letName repr)
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , G.Matchable repr
  ) => G.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 $
    G.conditional
      <$> unObserveSharing a
      <*> pure cs
      <*> mapM unObserveSharing bs
      <*> unObserveSharing b
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , G.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
   -}
  , G.Applicable repr
  , G.Alternable repr
  ) => G.Foldable (ObserveSharing letName repr)
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , G.Lookable repr
  ) => G.Lookable (ObserveSharing letName repr)

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