src/Symantic/Parser/Grammar/ObserveSharing.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2 module Symantic.Parser.Grammar.ObserveSharing
   3   ( module Symantic.Univariant.Letable
   4   , module Symantic.Parser.Grammar.ObserveSharing
   5   ) where
   6
   7 import Control.Monad (mapM)
   8 import Data.Eq (Eq(..))
   9 import Data.Function (($), (.))
  10 import Data.Hashable (Hashable, hashWithSalt)
  11 import Text.Show (Show(..))
  12 import qualified Control.Applicative as Functor
  13
  14 import Symantic.Parser.Grammar.Combinators
  15 import Symantic.Univariant.Letable hiding (observeSharing)
  16 import qualified Symantic.Univariant.Letable as Letable
  17 import qualified Language.Haskell.TH.Syntax as TH
  18 import qualified Symantic.Univariant.Trans as Sym
  19
  20 -- | Like 'Letable.observeSharing'
  21 -- but type-binding @(letName)@ to 'TH.Name'
  22 -- to avoid the trouble to always set it.
  23 observeSharing :: ObserveSharing TH.Name repr a -> repr a
  24 observeSharing = Letable.observeSharing
  25
  26 -- | Needed by 'observeSharing'.
  27 instance Hashable TH.Name where
  28   hashWithSalt s = hashWithSalt s . show
  29
  30 -- Combinators semantics for the 'ObserveSharing' interpreter.
  31 instance
  32   ( Letable letName repr
  33   , MakeLetName letName
  34   , Eq letName
  35   , Hashable letName
  36   , Satisfiable tok repr
  37   ) => Satisfiable tok (ObserveSharing letName repr)
  38 instance
  39   ( Letable letName repr
  40   , MakeLetName letName
  41   , Eq letName
  42   , Hashable letName
  43   , Alternable repr
  44   ) => Alternable (ObserveSharing letName repr)
  45 instance
  46   ( Letable letName repr
  47   , MakeLetName letName
  48   , Eq letName
  49   , Hashable letName
  50   , Applicable repr
  51   ) => Applicable (ObserveSharing letName repr)
  52 instance
  53   ( Letable letName repr
  54   , MakeLetName letName
  55   , Eq letName
  56   , Hashable letName
  57   , Selectable repr
  58   ) => Selectable (ObserveSharing letName repr)
  59 instance
  60   ( Letable letName repr
  61   , MakeLetName letName
  62   , Eq letName
  63   , Hashable letName
  64   , Matchable repr
  65   ) => Matchable (ObserveSharing letName repr) where
  66   -- Here the default definition does not fit
  67   -- since there is no lift* for the type of 'conditional'
  68   -- and its default definition does not handles 'bs'
  69   -- as needed by the 'ObserveSharing' transformation.
  70   conditional a cs bs b = observeSharingNode $ ObserveSharing $
  71     conditional
  72       Functor.<$> unObserveSharing a
  73       Functor.<*> Functor.pure cs
  74       Functor.<*> mapM unObserveSharing bs
  75       Functor.<*> unObserveSharing b
  76 instance
  77   ( Letable letName repr
  78   , MakeLetName letName
  79   , Eq letName
  80   , Hashable letName
  81   , Foldable repr
  82   {- TODO: the following constraints are for the current Foldable,
  83    - they will have to be removed when Foldable will have Sym.lift2 as defaults
  84    -}
  85   , Applicable repr
  86   , Alternable repr
  87   ) => Foldable (ObserveSharing letName repr)
  88 instance
  89   ( Letable letName repr
  90   , MakeLetName letName
  91   , Eq letName
  92   , Hashable letName
  93   , Lookable repr
  94   ) => Lookable (ObserveSharing letName repr)
  95
  96 -- Combinators semantics for the 'CleanDefs' interpreter.
  97 instance Applicable repr => Applicable (CleanDefs letName repr)
  98 instance Alternable repr => Alternable (CleanDefs letName repr)
  99 instance Satisfiable tok repr => Satisfiable tok (CleanDefs letName repr)
 100 instance Selectable repr => Selectable (CleanDefs letName repr)
 101 instance Matchable repr => Matchable (CleanDefs letName repr) where
 102   conditional a cs bs b = CleanDefs $
 103     conditional
 104       Functor.<$> unCleanDefs a
 105       Functor.<*> Functor.pure cs
 106       Functor.<*> mapM unCleanDefs bs
 107       Functor.<*> unCleanDefs b
 108 instance Lookable repr => Lookable (CleanDefs letName repr)
 109 instance Foldable repr => Foldable (CleanDefs letName repr) where
 110   chainPre = Sym.lift2 chainPre
 111   chainPost = Sym.lift2 chainPost