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 G
  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   , G.Satisfiable repr tok
  35   ) => G.Satisfiable (ObserveSharing letName repr) tok
  36 instance
  37   ( Letable letName repr
  38   , MakeLetName letName
  39   , Eq letName
  40   , Hashable letName
  41   , G.Alternable repr
  42   ) => G.Alternable (ObserveSharing letName repr)
  43 instance
  44   ( Letable letName repr
  45   , MakeLetName letName
  46   , Eq letName
  47   , Hashable letName
  48   , G.Applicable repr
  49   ) => G.Applicable (ObserveSharing letName repr)
  50 instance
  51   ( Letable letName repr
  52   , MakeLetName letName
  53   , Eq letName
  54   , Hashable letName
  55   , G.Selectable repr
  56   ) => G.Selectable (ObserveSharing letName repr)
  57 instance
  58   ( Letable letName repr
  59   , MakeLetName letName
  60   , Eq letName
  61   , Hashable letName
  62   , G.Matchable repr
  63   ) => G.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 does not handles 'bs'
  67   -- as needed by the 'ObserveSharing' transformation.
  68   conditional a cs bs b = observeSharingNode $ ObserveSharing $
  69     G.conditional
  70       <$> unObserveSharing a
  71       <*> pure cs
  72       <*> mapM unObserveSharing bs
  73       <*> unObserveSharing b
  74 instance
  75   ( Letable letName repr
  76   , MakeLetName letName
  77   , Eq letName
  78   , Hashable letName
  79   , G.Foldable repr
  80   {- TODO: the following constraints are for the current Foldable,
  81    - they will have to be removed when Foldable will have Sym.lift2 as defaults
  82    -}
  83   , G.Applicable repr
  84   , G.Alternable repr
  85   ) => G.Foldable (ObserveSharing letName repr)
  86 instance
  87   ( Letable letName repr
  88   , MakeLetName letName
  89   , Eq letName
  90   , Hashable letName
  91   , G.Lookable repr
  92   ) => G.Lookable (ObserveSharing letName repr)
  93
  94 -- Combinators semantics for the 'CleanDefs' interpreter
  95 instance G.Applicable repr => G.Applicable (CleanDefs letName repr)
  96 instance G.Alternable repr => G.Alternable (CleanDefs letName repr)
  97 instance G.Satisfiable repr tok => G.Satisfiable (CleanDefs letName repr) tok
  98 instance G.Selectable repr => G.Selectable (CleanDefs letName repr)
  99 instance G.Matchable repr => G.Matchable (CleanDefs letName repr) where
 100   conditional a cs bs b = CleanDefs $
 101     G.conditional
 102       <$> unCleanDefs a
 103       <*> pure cs
 104       <*> mapM unCleanDefs bs
 105       <*> unCleanDefs b
 106 instance G.Lookable repr => G.Lookable (CleanDefs letName repr)
 107 instance G.Foldable repr => G.Foldable (CleanDefs letName repr) where
 108   chainPre = Sym.lift2 G.chainPre
 109   chainPost = Sym.lift2 G.chainPost