{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.Parser.Grammar.ObserveSharing
  ( module Symantic.Typed.Letable
  , 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.Letable hiding (observeSharing)
import qualified Symantic.Typed.Letable as Letable
import qualified Language.Haskell.TH.Syntax as TH
import qualified Symantic.Typed.Trans as Sym

-- | Like 'Letable.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) = Letable.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 Sym.lift2 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 = Sym.lift2 chainPre
  chainPost = Sym.lift2 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)