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.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.Univariant.Letable hiding (observeSharing)
  15 import qualified Symantic.Univariant.Letable as Letable
  16 import qualified Language.Haskell.TH.Syntax as TH
  17 import qualified Symantic.Univariant.Trans as Sym
  18
  19 -- | Like 'Letable.observeSharing'
  20 -- but type-binding @(letName)@ to 'TH.Name'
  21 -- to avoid the trouble to always set it.
  22 observeSharing ::
  23   Letsable TH.Name repr =>
  24   ObserveSharing TH.Name repr a ->
  25   repr a
  26 observeSharing os = lets defs body
  27   where (body, defs) = Letable.observeSharing os
  28
  29 -- | Needed by 'observeSharing'.
  30 instance Hashable TH.Name where
  31   hashWithSalt s = hashWithSalt s . show
  32 instance MakeLetName TH.Name where
  33   makeLetName _ = TH.qNewName "name"
  34
  35 -- Combinators semantics for the 'ObserveSharing' interpreter.
  36 instance
  37   ( Letable TH.Name repr
  38   , Satisfiable tok repr
  39   ) => Satisfiable tok (ObserveSharing TH.Name repr)
  40 instance
  41   ( Letable TH.Name repr
  42   , Alternable repr
  43   ) => Alternable (ObserveSharing TH.Name repr)
  44 instance
  45   ( Letable TH.Name repr
  46   , Applicable repr
  47   ) => Applicable (ObserveSharing TH.Name repr)
  48 instance
  49   ( Letable TH.Name repr
  50   , Selectable repr
  51   ) => Selectable (ObserveSharing TH.Name repr)
  52 instance
  53   ( Letable TH.Name repr
  54   , Matchable repr
  55   ) => Matchable (ObserveSharing TH.Name repr) where
  56   -- Here the default definition does not fit
  57   -- since there is no lift* for the type of 'conditional'
  58   -- and its default definition does not handles 'bs'
  59   -- as needed by the 'ObserveSharing' transformation.
  60   conditional a cs bs b = observeSharingNode $ ObserveSharing $
  61     conditional
  62       Functor.<$> unObserveSharing a
  63       Functor.<*> Functor.pure cs
  64       Functor.<*> mapM unObserveSharing bs
  65       Functor.<*> unObserveSharing b
  66 instance
  67   ( Letable TH.Name repr
  68   , Foldable repr
  69   {- TODO: the following constraints are for the current Foldable,
  70    - they will have to be removed when Foldable will have Sym.lift2 as defaults
  71    -}
  72   , Applicable repr
  73   , Alternable repr
  74   ) => Foldable (ObserveSharing TH.Name repr)
  75 instance
  76   ( Letable TH.Name repr
  77   , Lookable repr
  78   ) => Lookable (ObserveSharing TH.Name repr)
  79
  80 -- Combinators semantics for the 'FinalizeSharing' interpreter.
  81 instance Applicable repr => Applicable (FinalizeSharing TH.Name repr)
  82 instance Alternable repr => Alternable (FinalizeSharing TH.Name repr)
  83 instance Satisfiable tok repr => Satisfiable tok (FinalizeSharing TH.Name repr)
  84 instance Selectable repr => Selectable (FinalizeSharing TH.Name repr)
  85 instance Matchable repr => Matchable (FinalizeSharing TH.Name repr) where
  86   conditional a cs bs b = FinalizeSharing $
  87     conditional
  88       Functor.<$> unFinalizeSharing a
  89       Functor.<*> Functor.pure cs
  90       Functor.<*> mapM unFinalizeSharing bs
  91       Functor.<*> unFinalizeSharing b
  92 instance Lookable repr => Lookable (FinalizeSharing TH.Name repr)
  93 instance Foldable repr => Foldable (FinalizeSharing TH.Name repr) where
  94   chainPre = Sym.lift2 chainPre
  95   chainPost = Sym.lift2 chainPost