src/Symantic/Parser/Grammar/ObserveSharing.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2 module Symantic.Parser.Grammar.ObserveSharing
   3   ( module Symantic.ObserveSharing
   4   , module Symantic.Parser.Grammar.ObserveSharing
   5   ) where
   6
   7 import Control.Monad (mapM)
   8 import Data.Function (($), (.))
   9 import Data.Hashable (Hashable, hashWithSalt)
  10 import Text.Show (Show(..))
  11 import qualified Control.Applicative as Functor
  12
  13 import Symantic.Parser.Grammar.Combinators
  14 import Symantic.Derive
  15 import Symantic.ObserveSharing hiding (observeSharing)
  16 import qualified Symantic.ObserveSharing as ObserveSharing
  17 import qualified Language.Haskell.TH.Syntax as TH
  18
  19 -- | Like 'Observable.observeSharing'
  20 -- but type-binding @(letName)@ to 'TH.Name'
  21 -- to avoid the trouble to always set it.
  22 observeSharing :: Letsable TH.Name repr => ObserveSharing TH.Name repr a -> repr a
  23 observeSharing os = lets defs body
  24   where (body, defs) = ObserveSharing.observeSharing os
  25
  26 -- | Needed by 'observeSharing'.
  27 instance Hashable TH.Name where
  28   hashWithSalt s = hashWithSalt s . show
  29 instance MakeLetName TH.Name where
  30   makeLetName _ = TH.qNewName "name"
  31
  32 -- Combinators semantics for the 'ObserveSharing' interpreter.
  33 instance (Letable TH.Name repr, CombAlternable repr) =>
  34   CombAlternable (ObserveSharing TH.Name repr)
  35 instance (Letable TH.Name repr, CombApplicable repr) =>
  36   CombApplicable (ObserveSharing TH.Name repr)
  37 instance
  38   ( Letable TH.Name repr
  39   , CombFoldable repr
  40   {- TODO: the following constraints are for the current CombFoldable,
  41    - they will have to be removed when CombFoldable will have 'liftDerived2' as defaults
  42    -}
  43   , CombApplicable repr
  44   , CombAlternable repr
  45   ) => CombFoldable (ObserveSharing TH.Name repr)
  46 instance (Letable TH.Name repr, CombLookable repr) =>
  47   CombLookable (ObserveSharing TH.Name repr)
  48 instance (Letable TH.Name repr, CombMatchable repr) =>
  49   CombMatchable (ObserveSharing TH.Name repr) where
  50   -- Here the default definition does not fit
  51   -- since there is no liftDerived* for the type of 'conditional'
  52   -- and its default definition does not handles 'bs'
  53   -- as needed by the 'ObserveSharing' interpreter.
  54   conditional a cs bs b = observeSharingNode $ ObserveSharing $
  55     conditional
  56       Functor.<$> unObserveSharing a
  57       Functor.<*> Functor.pure cs
  58       Functor.<*> mapM unObserveSharing bs
  59       Functor.<*> unObserveSharing b
  60 instance (Letable TH.Name repr, CombSelectable repr) =>
  61   CombSelectable (ObserveSharing TH.Name repr)
  62 instance (Letable TH.Name repr, CombSatisfiable tok repr) =>
  63   CombSatisfiable tok (ObserveSharing TH.Name repr)
  64
  65 -- Combinators semantics for the 'FinalizeSharing' interpreter.
  66 instance CombApplicable repr => CombApplicable (FinalizeSharing TH.Name repr)
  67 instance CombAlternable repr => CombAlternable (FinalizeSharing TH.Name repr)
  68 instance CombFoldable repr => CombFoldable (FinalizeSharing TH.Name repr) where
  69   chainPre = liftDerived2 chainPre
  70   chainPost = liftDerived2 chainPost
  71 instance CombLookable repr => CombLookable (FinalizeSharing TH.Name repr)
  72 instance CombMatchable repr => CombMatchable (FinalizeSharing TH.Name repr) where
  73   conditional a cs bs b = FinalizeSharing $
  74     conditional
  75       Functor.<$> unFinalizeSharing a
  76       Functor.<*> Functor.pure cs
  77       Functor.<*> mapM unFinalizeSharing bs
  78       Functor.<*> unFinalizeSharing b
  79 instance CombSatisfiable tok repr => CombSatisfiable tok (FinalizeSharing TH.Name repr)
  80 instance CombSelectable repr => CombSelectable (FinalizeSharing TH.Name repr)