{-# 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 :: 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

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
  , 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 :: forall a b.
Eq a =>
[Haskell (a -> Bool)]
-> [ObserveSharing letName repr b]
-> ObserveSharing letName repr a
-> ObserveSharing letName repr b
-> ObserveSharing letName repr b
conditional [Haskell (a -> Bool)]
cs [ObserveSharing letName repr b]
bs ObserveSharing letName repr a
a 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
$
    [Haskell (a -> Bool)]
-> [CleanDefs letName repr b]
-> CleanDefs letName repr a
-> CleanDefs letName repr b
-> CleanDefs letName repr b
forall (repr :: * -> *) a b.
(Matchable repr, Eq a) =>
[Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
Comb.conditional [Haskell (a -> Bool)]
cs
      ([CleanDefs letName repr b]
 -> CleanDefs letName repr a
 -> 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 a
      -> CleanDefs letName repr b -> CleanDefs letName repr b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 a
   -> CleanDefs letName repr b -> CleanDefs letName repr b)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
-> 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
<*> 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))
  (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
<*> 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
  , 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 :: forall a b.
Eq a =>
[Haskell (a -> Bool)]
-> [CleanDefs letName repr b]
-> CleanDefs letName repr a
-> CleanDefs letName repr b
-> CleanDefs letName repr b
conditional [Haskell (a -> Bool)]
cs [CleanDefs letName repr b]
bs CleanDefs letName repr a
a 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
$
    [Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
forall (repr :: * -> *) a b.
(Matchable repr, Eq a) =>
[Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
Comb.conditional [Haskell (a -> Bool)]
cs
      ([repr b] -> repr a -> repr b -> repr b)
-> (HashSet letName -> [repr b])
-> HashSet letName
-> repr a
-> repr b
-> repr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 a -> repr b -> repr b)
-> (HashSet letName -> repr a)
-> HashSet letName
-> repr b
-> repr b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 -> 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
<*> 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 Comb.Lookable repr => Comb.Lookable (CleanDefs letName repr)
instance Comb.Foldable repr => Comb.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
Comb.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
Comb.chainPost