src/Symantic/Parser/Grammar/ObserveSharing.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2 module Symantic.Parser.Grammar.ObserveSharing
   3  ( module Symantic.Parser.Grammar.ObserveSharing
   4  , ObserveSharing(..)
   5  ) where
   6
   7 import Control.Monad (mapM)
   8 import Control.Applicative (Applicative(..))
   9 import Data.Eq (Eq(..))
  10 import Data.Function (($), (.))
  11 import Data.Functor ((<$>))
  12 import Data.Hashable (Hashable, hashWithSalt)
  13 import Text.Show (Show(..))
  14
  15 import Symantic.Univariant.Letable as Letable
  16 import qualified Symantic.Parser.Grammar.Combinators as Comb
  17 import qualified Language.Haskell.TH.Syntax as TH
  18
  19 -- | Like 'Letable.observeSharing' but type-binding @(letName)@ to 'TH.Name' to help type inference.
  20 observeSharing :: ObserveSharing TH.Name repr a -> repr a
  21 observeSharing = Letable.observeSharing
  22
  23 instance Hashable TH.Name where
  24   hashWithSalt s = hashWithSalt s . show
  25
  26 -- Combinators semantics for the 'ObserveSharing' interpreter
  27 instance
  28   ( Letable letName repr
  29   , MakeLetName letName
  30   , Eq letName
  31   , Hashable letName
  32   , Comb.Charable repr
  33   ) => Comb.Charable (ObserveSharing letName repr)
  34 instance
  35   ( Letable letName repr
  36   , MakeLetName letName
  37   , Eq letName
  38   , Hashable letName
  39   , Comb.Alternable repr
  40   ) => Comb.Alternable (ObserveSharing letName repr)
  41 instance
  42   ( Letable letName repr
  43   , MakeLetName letName
  44   , Eq letName
  45   , Hashable letName
  46   , Comb.Applicable repr
  47   ) => Comb.Applicable (ObserveSharing letName repr)
  48 instance
  49   ( Letable letName repr
  50   , MakeLetName letName
  51   , Eq letName
  52   , Hashable letName
  53   , Comb.Selectable repr
  54   ) => Comb.Selectable (ObserveSharing letName repr)
  55 instance
  56   ( Letable letName repr
  57   , MakeLetName letName
  58   , Eq letName
  59   , Hashable letName
  60   , Comb.Matchable repr
  61   ) => Comb.Matchable (ObserveSharing letName repr) where
  62   -- Here the default definition does not fit since there is no lift* for its type and thus handles 'bs' itself,
  63   -- which is not the transformation wanted.
  64   conditional cs bs a b = observeSharingNode $ ObserveSharing $
  65     Comb.conditional cs
  66       <$> mapM unObserveSharing bs
  67       <*> unObserveSharing a
  68       <*> unObserveSharing b
  69 instance
  70   ( Letable letName repr
  71   , MakeLetName letName
  72   , Eq letName
  73   , Hashable letName
  74   , Comb.Foldable repr
  75   ) => Comb.Foldable (ObserveSharing letName repr)
  76 instance
  77   ( Letable letName repr
  78   , MakeLetName letName
  79   , Eq letName
  80   , Hashable letName
  81   , Comb.Lookable repr
  82   ) => Comb.Lookable (ObserveSharing letName repr)
  83
  84 -- Combinators semantics for the 'CleanDefs' interpreter
  85 instance Comb.Applicable repr => Comb.Applicable (CleanDefs letName repr)
  86 instance Comb.Alternable repr => Comb.Alternable (CleanDefs letName repr)
  87 instance Comb.Charable repr => Comb.Charable (CleanDefs letName repr)
  88 instance Comb.Selectable repr => Comb.Selectable (CleanDefs letName repr)
  89 instance Comb.Matchable repr => Comb.Matchable (CleanDefs letName repr) where
  90   conditional cs bs a b = CleanDefs $
  91     Comb.conditional cs
  92       <$> mapM unCleanDefs bs
  93       <*> unCleanDefs a
  94       <*> unCleanDefs b
  95 instance Comb.Lookable repr => Comb.Lookable (CleanDefs letName repr)
  96 instance Comb.Foldable repr => Comb.Foldable (CleanDefs letName repr)