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