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.Univariant.Trans as Sym
  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 -> 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   {- TODO: the following constraints are for the current Foldable,
  77    - they will have to be removed when Foldable will have Sym.lift2 as defaults
  78    -}
  79   , Comb.Applicable repr
  80   , Comb.Alternable repr
  81   ) => Comb.Foldable (ObserveSharing letName repr)
  82 instance
  83   ( Letable letName repr
  84   , MakeLetName letName
  85   , Eq letName
  86   , Hashable letName
  87   , Comb.Lookable repr
  88   ) => Comb.Lookable (ObserveSharing letName repr)
  89
  90 -- Combinators semantics for the 'CleanDefs' interpreter
  91 instance Comb.Applicable repr => Comb.Applicable (CleanDefs letName repr)
  92 instance Comb.Alternable repr => Comb.Alternable (CleanDefs letName repr)
  93 instance Comb.Charable repr => Comb.Charable (CleanDefs letName repr)
  94 instance Comb.Selectable repr => Comb.Selectable (CleanDefs letName repr)
  95 instance Comb.Matchable repr => Comb.Matchable (CleanDefs letName repr) where
  96   conditional cs bs a b = CleanDefs $
  97     Comb.conditional cs
  98       <$> mapM unCleanDefs bs
  99       <*> unCleanDefs a
 100       <*> unCleanDefs b
 101 instance Comb.Lookable repr => Comb.Lookable (CleanDefs letName repr)
 102 instance Comb.Foldable repr => Comb.Foldable (CleanDefs letName repr) where
 103   chainPre = Sym.lift2 Comb.chainPre
 104   chainPost = Sym.lift2 Comb.chainPost