{-# 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 :: forall (repr :: * -> *) a. ObserveSharing Name repr a -> repr a
observeSharing = ObserveSharing Name repr a -> repr a
forall letName (repr :: * -> *) a.
(Eq letName, Hashable letName) =>
ObserveSharing letName repr a -> repr a
Letable.observeSharing

-- | Needed by 'observeSharing'.
instance Hashable TH.Name where
  hashWithSalt :: Int -> Name -> Int
hashWithSalt Int
s = Int -> String -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (String -> Int) -> (Name -> String) -> Name -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Show a => a -> String
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 :: forall a b.
Eq a =>
ObserveSharing letName repr a
-> [TermGrammar (a -> Bool)]
-> [ObserveSharing letName repr b]
-> ObserveSharing letName repr b
-> ObserveSharing letName repr b
conditional ObserveSharing letName repr a
a [TermGrammar (a -> Bool)]
cs [ObserveSharing letName repr b]
bs ObserveSharing letName repr b
b = ObserveSharing letName repr b -> ObserveSharing letName repr b
forall letName (repr :: * -> *) a.
(Eq letName, Hashable letName, Letable letName repr,
 MakeLetName letName) =>
ObserveSharing letName repr a -> ObserveSharing letName repr a
observeSharingNode (ObserveSharing letName repr b -> ObserveSharing letName repr b)
-> ObserveSharing letName repr b -> ObserveSharing letName repr b
forall a b. (a -> b) -> a -> b
$ ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr b)
-> ObserveSharing letName repr b
forall letName (repr :: * -> *) a.
ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr a)
-> ObserveSharing letName repr a
ObserveSharing (ReaderT
   (HashSet SharingName)
   (State (ObserveSharingState letName))
   (CleanDefs letName repr b)
 -> ObserveSharing letName repr b)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr b)
-> ObserveSharing letName repr b
forall a b. (a -> b) -> a -> b
$
    CleanDefs letName repr a
-> [TermGrammar (a -> Bool)]
-> [CleanDefs letName repr b]
-> CleanDefs letName repr b
-> CleanDefs letName repr b
forall (repr :: * -> *) a b.
(Matchable repr, Eq a) =>
repr a -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b
conditional
      (CleanDefs letName repr a
 -> [TermGrammar (a -> Bool)]
 -> [CleanDefs letName repr b]
 -> CleanDefs letName repr b
 -> CleanDefs letName repr b)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     ([TermGrammar (a -> Bool)]
      -> [CleanDefs letName repr b]
      -> CleanDefs letName repr b
      -> CleanDefs letName repr b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Functor.<$> ObserveSharing letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
forall letName (repr :: * -> *) a.
ObserveSharing letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
unObserveSharing ObserveSharing letName repr a
a
      ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  ([TermGrammar (a -> Bool)]
   -> [CleanDefs letName repr b]
   -> CleanDefs letName repr b
   -> CleanDefs letName repr b)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     [TermGrammar (a -> Bool)]
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     ([CleanDefs letName repr b]
      -> CleanDefs letName repr b -> CleanDefs letName repr b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
Functor.<*> [TermGrammar (a -> Bool)]
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     [TermGrammar (a -> Bool)]
forall (f :: * -> *) a. Applicative f => a -> f a
Functor.pure [TermGrammar (a -> Bool)]
cs
      ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  ([CleanDefs letName repr b]
   -> CleanDefs letName repr b -> CleanDefs letName repr b)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     [CleanDefs letName repr b]
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr b -> CleanDefs letName repr b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
Functor.<*> (ObserveSharing letName repr b
 -> ReaderT
      (HashSet SharingName)
      (State (ObserveSharingState letName))
      (CleanDefs letName repr b))
-> [ObserveSharing letName repr b]
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     [CleanDefs letName repr b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ObserveSharing letName repr b
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr b)
forall letName (repr :: * -> *) a.
ObserveSharing letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
unObserveSharing [ObserveSharing letName repr b]
bs
      ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr b -> CleanDefs letName repr b)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr b)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
Functor.<*> ObserveSharing letName repr b
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr b)
forall letName (repr :: * -> *) a.
ObserveSharing letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
unObserveSharing ObserveSharing letName repr b
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 :: forall a b.
Eq a =>
CleanDefs letName repr a
-> [TermGrammar (a -> Bool)]
-> [CleanDefs letName repr b]
-> CleanDefs letName repr b
-> CleanDefs letName repr b
conditional CleanDefs letName repr a
a [TermGrammar (a -> Bool)]
cs [CleanDefs letName repr b]
bs CleanDefs letName repr b
b = (HashSet letName -> repr b) -> CleanDefs letName repr b
forall letName (repr :: * -> *) a.
(HashSet letName -> repr a) -> CleanDefs letName repr a
CleanDefs ((HashSet letName -> repr b) -> CleanDefs letName repr b)
-> (HashSet letName -> repr b) -> CleanDefs letName repr b
forall a b. (a -> b) -> a -> b
$
    repr a -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b
forall (repr :: * -> *) a b.
(Matchable repr, Eq a) =>
repr a -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b
conditional
      (repr a
 -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b)
-> (HashSet letName -> repr a)
-> HashSet letName
-> [TermGrammar (a -> Bool)]
-> [repr b]
-> repr b
-> repr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Functor.<$> CleanDefs letName repr a -> HashSet letName -> repr a
forall letName (repr :: * -> *) a.
CleanDefs letName repr a -> HashSet letName -> repr a
unCleanDefs CleanDefs letName repr a
a
      (HashSet letName
 -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b)
-> (HashSet letName -> [TermGrammar (a -> Bool)])
-> HashSet letName
-> [repr b]
-> repr b
-> repr b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
Functor.<*> [TermGrammar (a -> Bool)]
-> HashSet letName -> [TermGrammar (a -> Bool)]
forall (f :: * -> *) a. Applicative f => a -> f a
Functor.pure [TermGrammar (a -> Bool)]
cs
      (HashSet letName -> [repr b] -> repr b -> repr b)
-> (HashSet letName -> [repr b])
-> HashSet letName
-> repr b
-> repr b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
Functor.<*> (CleanDefs letName repr b -> HashSet letName -> repr b)
-> [CleanDefs letName repr b] -> HashSet letName -> [repr b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CleanDefs letName repr b -> HashSet letName -> repr b
forall letName (repr :: * -> *) a.
CleanDefs letName repr a -> HashSet letName -> repr a
unCleanDefs [CleanDefs letName repr b]
bs
      (HashSet letName -> repr b -> repr b)
-> (HashSet letName -> repr b) -> HashSet letName -> repr b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
Functor.<*> CleanDefs letName repr b -> HashSet letName -> repr b
forall letName (repr :: * -> *) a.
CleanDefs letName repr a -> HashSet letName -> repr a
unCleanDefs CleanDefs letName repr b
b
instance Lookable repr => Lookable (CleanDefs letName repr)
instance Foldable repr => Foldable (CleanDefs letName repr) where
  chainPre :: forall a.
CleanDefs letName repr (a -> a)
-> CleanDefs letName repr a -> CleanDefs letName repr a
chainPre = (Output (CleanDefs letName repr) (a -> a)
 -> Output (CleanDefs letName repr) a
 -> Output (CleanDefs letName repr) a)
-> CleanDefs letName repr (a -> a)
-> CleanDefs letName repr a
-> CleanDefs letName repr a
forall (repr :: * -> *) a b c.
Liftable2 repr =>
(Output repr a -> Output repr b -> Output repr c)
-> repr a -> repr b -> repr c
Sym.lift2 Output (CleanDefs letName repr) (a -> a)
-> Output (CleanDefs letName repr) a
-> Output (CleanDefs letName repr) a
forall (repr :: * -> *) a.
Foldable repr =>
repr (a -> a) -> repr a -> repr a
chainPre
  chainPost :: forall a.
CleanDefs letName repr a
-> CleanDefs letName repr (a -> a) -> CleanDefs letName repr a
chainPost = (Output (CleanDefs letName repr) a
 -> Output (CleanDefs letName repr) (a -> a)
 -> Output (CleanDefs letName repr) a)
-> CleanDefs letName repr a
-> CleanDefs letName repr (a -> a)
-> CleanDefs letName repr a
forall (repr :: * -> *) a b c.
Liftable2 repr =>
(Output repr a -> Output repr b -> Output repr c)
-> repr a -> repr b -> repr c
Sym.lift2 Output (CleanDefs letName repr) a
-> Output (CleanDefs letName repr) (a -> a)
-> Output (CleanDefs letName repr) a
forall (repr :: * -> *) a.
Foldable repr =>
repr a -> repr (a -> a) -> repr a
chainPost