src/Symantic/Parser/Grammar/SharingObserver.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 {-# LANGUAGE TupleSections #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Symantic.Parser.Grammar.SharingObserver
   5   ( module Symantic.Semantics.SharingObserver
   6   , module Symantic.Parser.Grammar.SharingObserver
   7   ) where
   8
   9 import Control.Monad (mapM)
  10 import Data.Function (($), (.))
  11 import Data.Hashable (Hashable, hashWithSalt)
  12 import System.IO.Unsafe (unsafePerformIO) -- For 'new'
  13 import Text.Show (Show(..))
  14 import qualified Control.Applicative as App
  15
  16 import Symantic.Parser.Grammar.Combinators
  17 import Symantic.Syntaxes.Derive
  18 import Symantic.Semantics.SharingObserver hiding (sharingObserver)
  19 import qualified Symantic.Semantics.SharingObserver as SharingObserver
  20 import qualified Language.Haskell.TH.Syntax as TH
  21
  22 -- | Like 'Observable.sharingObserver'
  23 -- but type-binding @(letName)@ to 'TH.Name'
  24 -- to avoid the trouble to always set it.
  25 sharingObserver :: Letsable TH.Name repr => SharingObserver TH.Name repr a -> repr a
  26 sharingObserver os = lets defs body
  27   where (body, defs) = SharingObserver.sharingObserver os
  28
  29 -- | Needed by 'sharingObserver'.
  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 'SharingObserver' interpreter.
  36 instance
  37   ( Referenceable TH.Name repr
  38   , CombAlternable repr
  39   ) => CombAlternable (SharingObserver TH.Name repr)
  40 instance
  41   ( Referenceable TH.Name repr
  42   , CombApplicable repr
  43   ) => CombApplicable (SharingObserver TH.Name repr)
  44 instance
  45   ( Referenceable TH.Name repr
  46   , CombFoldable repr
  47   ) => CombFoldable (SharingObserver TH.Name repr)
  48 instance
  49   ( Referenceable TH.Name repr
  50   , CombLookable repr
  51   ) => CombLookable (SharingObserver TH.Name repr)
  52 instance
  53   ( Referenceable TH.Name repr
  54   , CombMatchable repr
  55   ) => CombMatchable (SharingObserver TH.Name repr) where
  56   -- Here the default definition does not fit
  57   -- since there is no liftDerived* for the type of 'conditional'
  58   -- and its default definition does not handles 'bs'
  59   -- as needed by the 'SharingObserver' interpreter.
  60   conditional a bs d = sharingObserverNode $ SharingObserver $ conditional
  61     App.<$> unSharingObserver a
  62     App.<*> mapM (\(p, b) -> (p,) App.<$> unSharingObserver b) bs
  63     App.<*> unSharingObserver d
  64 instance
  65   ( Referenceable TH.Name repr
  66   , CombSelectable repr
  67   ) => CombSelectable (SharingObserver TH.Name repr)
  68 instance
  69   ( Referenceable TH.Name repr
  70   , CombSatisfiable tok repr
  71   ) => CombSatisfiable tok (SharingObserver TH.Name repr)
  72 instance
  73   ( Referenceable TH.Name repr
  74   , CombRegisterableUnscoped repr
  75   ) => CombRegisterable (SharingObserver TH.Name repr) where
  76   new ini f =
  77     -- 'unsafePerformIO' is used here because propagating 'IO'
  78     -- would prevent 'sharingObserver' to recognize recursive let,
  79     -- causing an infinite loop on them.
  80     let !regName = unsafePerformIO $ TH.newName "reg" in
  81     let reg = UnscopedRegister regName in
  82     newUnscoped reg ini (f (Register reg))
  83   get = getUnscoped . unRegister
  84   put reg = putUnscoped (unRegister reg)
  85 instance
  86   ( Referenceable TH.Name repr
  87   , CombRegisterableUnscoped repr
  88   ) => CombRegisterableUnscoped (SharingObserver TH.Name repr)
  89
  90 -- * Class 'CombRegisterableUnscoped'
  91 -- | These combinators are used to remove the @Rank2Types@ from 'CombRegisterable'
  92 -- in order to be able to 'sharingObserver'.
  93 class CombRegisterableUnscoped (repr::ReprComb) where
  94   newUnscoped :: UnscopedRegister a -> repr a -> repr b -> repr b
  95   getUnscoped :: UnscopedRegister a -> repr a
  96   putUnscoped :: UnscopedRegister a -> repr a -> repr ()
  97   default newUnscoped ::
  98     FromDerived2 CombRegisterableUnscoped repr =>
  99     UnscopedRegister a -> repr a -> repr b -> repr b
 100   default getUnscoped ::
 101     FromDerived CombRegisterableUnscoped repr =>
 102     UnscopedRegister a -> repr a
 103   default putUnscoped ::
 104     FromDerived1 CombRegisterableUnscoped repr =>
 105     UnscopedRegister a -> repr a -> repr ()
 106   newUnscoped = liftDerived2 . newUnscoped
 107   getUnscoped = liftDerived . getUnscoped
 108   putUnscoped = liftDerived1 . putUnscoped
 109
 110 -- Combinators semantics for the 'SharingFinalizer' interpreter.
 111 instance
 112   ( CombApplicable repr
 113   ) => CombApplicable (SharingFinalizer TH.Name repr)
 114 instance
 115   ( CombAlternable repr
 116   ) => CombAlternable (SharingFinalizer TH.Name repr)
 117 instance
 118   ( CombFoldable repr
 119   ) => CombFoldable (SharingFinalizer TH.Name repr)
 120 instance
 121   ( CombLookable repr
 122   ) => CombLookable (SharingFinalizer TH.Name repr)
 123 instance
 124   ( CombMatchable repr
 125   ) => CombMatchable (SharingFinalizer TH.Name repr) where
 126   conditional a bs d = SharingFinalizer $ conditional
 127     App.<$> unSharingFinalizer a
 128     App.<*> mapM (\(p, b) -> (p,) App.<$> unSharingFinalizer b) bs
 129     App.<*> unSharingFinalizer d
 130 instance
 131   ( CombSatisfiable tok repr
 132   ) => CombSatisfiable tok (SharingFinalizer TH.Name repr)
 133 instance
 134   ( CombSelectable repr
 135   ) => CombSelectable (SharingFinalizer TH.Name repr)
 136 instance
 137   ( CombRegisterableUnscoped repr
 138   ) => CombRegisterableUnscoped (SharingFinalizer TH.Name repr)
 139
 140 -- | Call trace stack updated by 'call' and 'refJoin'.
 141 -- Used to avoid infinite loops when tying the knot with 'polyfix'.
 142 type CallTrace = [TH.Name]