src/Symantic/Parser/Grammar/ObserveSharing.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2 module Symantic.Parser.Grammar.ObserveSharing
   3   ( module Symantic.Univariant.Letable
   4   , module Symantic.Parser.Grammar.ObserveSharing
   5   ) where
   6
   7 import Control.Monad (mapM)
   8 import Data.Eq (Eq(..))
   9 import Data.Function (($), (.))
  10 import Data.Hashable (Hashable, hashWithSalt)
  11 import Text.Show (Show(..))
  12 import qualified Control.Applicative as Functor
  13
  14 import Symantic.Parser.Grammar.Combinators
  15 import Symantic.Univariant.Letable hiding (observeSharing)
  16 import qualified Symantic.Univariant.Letable as Letable
  17 import qualified Language.Haskell.TH.Syntax as TH
  18 import qualified Symantic.Univariant.Trans as Sym
  19
  20 -- | Like 'Letable.observeSharing'
  21 -- but type-binding @(letName)@ to 'TH.Name'
  22 -- to avoid the trouble to always set it.
  23 observeSharing :: ObserveSharing TH.Name repr a -> repr a
  24 observeSharing = Letable.observeSharing
  25
  26 -- | Needed by 'observeSharing'.
  27 instance Hashable TH.Name where
  28   hashWithSalt s = hashWithSalt s . show
  29
  30 -- Combinators semantics for the 'ObserveSharing' interpreter.
  31 instance
  32   ( Letable letName repr
  33   , MakeLetName letName
  34   , Eq letName
  35   , Hashable letName
  36   , Show letName
  37   , Satisfiable tok repr
  38   ) => Satisfiable tok (ObserveSharing letName repr)
  39 instance
  40   ( Letable letName repr
  41   , MakeLetName letName
  42   , Eq letName
  43   , Hashable letName
  44   , Show letName
  45   , Alternable repr
  46   ) => Alternable (ObserveSharing letName repr)
  47 instance
  48   ( Letable letName repr
  49   , MakeLetName letName
  50   , Eq letName
  51   , Hashable letName
  52   , Show letName
  53   , Applicable repr
  54   ) => Applicable (ObserveSharing letName repr)
  55 instance
  56   ( Letable letName repr
  57   , MakeLetName letName
  58   , Eq letName
  59   , Hashable letName
  60   , Show letName
  61   , Selectable repr
  62   ) => Selectable (ObserveSharing letName repr)
  63 instance
  64   ( Letable letName repr
  65   , MakeLetName letName
  66   , Eq letName
  67   , Hashable letName
  68   , Show letName
  69   , Matchable repr
  70   ) => Matchable (ObserveSharing letName repr) where
  71   -- Here the default definition does not fit
  72   -- since there is no lift* for the type of 'conditional'
  73   -- and its default definition does not handles 'bs'
  74   -- as needed by the 'ObserveSharing' transformation.
  75   conditional a cs bs b = observeSharingNode $ ObserveSharing $
  76     conditional
  77       Functor.<$> unObserveSharing a
  78       Functor.<*> Functor.pure cs
  79       Functor.<*> mapM unObserveSharing bs
  80       Functor.<*> unObserveSharing b
  81 instance
  82   ( Letable letName repr
  83   , MakeLetName letName
  84   , Eq letName
  85   , Hashable letName
  86   , Show letName
  87   , Foldable repr
  88   {- TODO: the following constraints are for the current Foldable,
  89    - they will have to be removed when Foldable will have Sym.lift2 as defaults
  90    -}
  91   , Applicable repr
  92   , Alternable repr
  93   ) => Foldable (ObserveSharing letName repr)
  94 instance
  95   ( Letable letName repr
  96   , MakeLetName letName
  97   , Eq letName
  98   , Hashable letName
  99   , Show letName
 100   , Lookable repr
 101   ) => Lookable (ObserveSharing letName repr)
 102
 103 -- Combinators semantics for the 'CleanDefs' interpreter.
 104 instance Applicable repr => Applicable (CleanDefs letName repr)
 105 instance Alternable repr => Alternable (CleanDefs letName repr)
 106 instance Satisfiable tok repr => Satisfiable tok (CleanDefs letName repr)
 107 instance Selectable repr => Selectable (CleanDefs letName repr)
 108 instance Matchable repr => Matchable (CleanDefs letName repr) where
 109   conditional a cs bs b = CleanDefs $
 110     conditional
 111       Functor.<$> unCleanDefs a
 112       Functor.<*> Functor.pure cs
 113       Functor.<*> mapM unCleanDefs bs
 114       Functor.<*> unCleanDefs b
 115 instance Lookable repr => Lookable (CleanDefs letName repr)
 116 instance Foldable repr => Foldable (CleanDefs letName repr) where
 117   chainPre = Sym.lift2 chainPre
 118   chainPost = Sym.lift2 chainPost