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 :: Letsable TH.Name repr => ObserveSharing TH.Name repr a -> repr a
  23 observeSharing os = lets defs body
  24   where (body, defs) = Letable.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 Sym.lift2 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 lift* for the type of 'conditional'
  52   -- and its default definition does not handles 'bs'
  53   -- as needed by the 'ObserveSharing' transformation.
  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 instance (Letable TH.Name repr, CombThrowable repr) =>
  65   CombThrowable (ObserveSharing TH.Name repr)
  66
  67 -- Combinators semantics for the 'FinalizeSharing' interpreter.
  68 instance CombApplicable repr => CombApplicable (FinalizeSharing TH.Name repr)
  69 instance CombAlternable repr => CombAlternable (FinalizeSharing TH.Name repr)
  70 instance CombFoldable repr => CombFoldable (FinalizeSharing TH.Name repr) where
  71   chainPre = Sym.lift2 chainPre
  72   chainPost = Sym.lift2 chainPost
  73 instance CombLookable repr => CombLookable (FinalizeSharing TH.Name repr)
  74 instance CombMatchable repr => CombMatchable (FinalizeSharing TH.Name repr) where
  75   conditional a cs bs b = FinalizeSharing $
  76     conditional
  77       Functor.<$> unFinalizeSharing a
  78       Functor.<*> Functor.pure cs
  79       Functor.<*> mapM unFinalizeSharing bs
  80       Functor.<*> unFinalizeSharing b
  81 instance CombSatisfiable tok repr => CombSatisfiable tok (FinalizeSharing TH.Name repr)
  82 instance CombSelectable repr => CombSelectable (FinalizeSharing TH.Name repr)
  83 instance CombThrowable repr => CombThrowable (FinalizeSharing TH.Name repr)