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'
  21 -- but type-binding @(letName)@ to 'TH.Name' to help type inference.
  22 observeSharing :: ObserveSharing TH.Name repr a -> repr a
  23 observeSharing = Letable.observeSharing
  24
  25 instance Hashable TH.Name where
  26   hashWithSalt s = hashWithSalt s . show
  27
  28 -- Combinators semantics for the 'ObserveSharing' interpreter
  29 instance
  30   ( Letable letName repr
  31   , MakeLetName letName
  32   , Eq letName
  33   , Hashable letName
  34   , Comb.Satisfiable repr tok
  35   ) => Comb.Satisfiable (ObserveSharing letName repr) tok
  36 instance
  37   ( Letable letName repr
  38   , MakeLetName letName
  39   , Eq letName
  40   , Hashable letName
  41   , Comb.Alternable repr
  42   ) => Comb.Alternable (ObserveSharing letName repr)
  43 instance
  44   ( Letable letName repr
  45   , MakeLetName letName
  46   , Eq letName
  47   , Hashable letName
  48   , Comb.Applicable repr
  49   ) => Comb.Applicable (ObserveSharing letName repr)
  50 instance
  51   ( Letable letName repr
  52   , MakeLetName letName
  53   , Eq letName
  54   , Hashable letName
  55   , Comb.Selectable repr
  56   ) => Comb.Selectable (ObserveSharing letName repr)
  57 instance
  58   ( Letable letName repr
  59   , MakeLetName letName
  60   , Eq letName
  61   , Hashable letName
  62   , Comb.Matchable repr
  63   ) => Comb.Matchable (ObserveSharing letName repr) where
  64   -- Here the default definition does not fit
  65   -- since there is no lift* for the type of 'conditional'
  66   -- and its default definition handles does not handles 'bs'
  67   -- as needed by the 'ObserveSharing' transformation.
  68   conditional cs bs a b = observeSharingNode $ ObserveSharing $
  69     Comb.conditional cs
  70       <$> mapM unObserveSharing bs
  71       <*> unObserveSharing a
  72       <*> unObserveSharing b
  73 instance
  74   ( Letable letName repr
  75   , MakeLetName letName
  76   , Eq letName
  77   , Hashable letName
  78   , Comb.Foldable repr
  79   {- TODO: the following constraints are for the current Foldable,
  80    - they will have to be removed when Foldable will have Sym.lift2 as defaults
  81    -}
  82   , Comb.Applicable repr
  83   , Comb.Alternable repr
  84   ) => Comb.Foldable (ObserveSharing letName repr)
  85 instance
  86   ( Letable letName repr
  87   , MakeLetName letName
  88   , Eq letName
  89   , Hashable letName
  90   , Comb.Lookable repr
  91   ) => Comb.Lookable (ObserveSharing letName repr)
  92
  93 -- Combinators semantics for the 'CleanDefs' interpreter
  94 instance Comb.Applicable repr => Comb.Applicable (CleanDefs letName repr)
  95 instance Comb.Alternable repr => Comb.Alternable (CleanDefs letName repr)
  96 instance Comb.Satisfiable repr tok => Comb.Satisfiable (CleanDefs letName repr) tok
  97 instance Comb.Selectable repr => Comb.Selectable (CleanDefs letName repr)
  98 instance Comb.Matchable repr => Comb.Matchable (CleanDefs letName repr) where
  99   conditional cs bs a b = CleanDefs $
 100     Comb.conditional cs
 101       <$> mapM unCleanDefs bs
 102       <*> unCleanDefs a
 103       <*> unCleanDefs b
 104 instance Comb.Lookable repr => Comb.Lookable (CleanDefs letName repr)
 105 instance Comb.Foldable repr => Comb.Foldable (CleanDefs letName repr) where
 106   chainPre = Sym.lift2 Comb.chainPre
 107   chainPost = Sym.lift2 Comb.chainPost