src/Symantic/Parser/Grammar/ObserveSharing.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2 module Symantic.Parser.Grammar.ObserveSharing
   3  ( Symantic.Parser.Grammar.ObserveSharing.observeSharing
   4  ) where
   5
   6 import Control.Monad (mapM)
   7 import Control.Applicative (Applicative(..))
   8 import Data.Eq (Eq(..))
   9 import Data.Function (($), (.))
  10 import Data.Functor ((<$>))
  11 import Data.Hashable (Hashable, hashWithSalt)
  12 import System.IO (IO)
  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 -> IO (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
  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)