src/Symantic/Parser/Grammar/ObserveSharing.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 {-# LANGUAGE TupleSections #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Symantic.Parser.Grammar.ObserveSharing
   5   ( module Symantic.ObserveSharing
   6   , module Symantic.Parser.Grammar.ObserveSharing
   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 F
  15
  16 import Symantic.Parser.Grammar.Combinators
  17 import Symantic.Derive
  18 import Symantic.ObserveSharing hiding (observeSharing)
  19 import qualified Symantic.ObserveSharing as ObserveSharing
  20 import qualified Language.Haskell.TH.Syntax as TH
  21
  22 -- | Like 'Observable.observeSharing'
  23 -- but type-binding @(letName)@ to 'TH.Name'
  24 -- to avoid the trouble to always set it.
  25 observeSharing :: Letsable TH.Name repr => ObserveSharing TH.Name repr a -> repr a
  26 observeSharing os = lets defs body
  27   where (body, defs) = ObserveSharing.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   ( Referenceable TH.Name repr
  38   , CombAlternable repr
  39   ) => CombAlternable (ObserveSharing TH.Name repr)
  40 instance
  41   ( Referenceable TH.Name repr
  42   , CombApplicable repr
  43   ) => CombApplicable (ObserveSharing TH.Name repr)
  44 instance
  45   ( Referenceable TH.Name repr
  46   , CombFoldable repr
  47   ) => CombFoldable (ObserveSharing TH.Name repr)
  48 instance
  49   ( Referenceable TH.Name repr
  50   , CombLookable repr
  51   ) => CombLookable (ObserveSharing TH.Name repr)
  52 instance
  53   ( Referenceable TH.Name repr
  54   , CombMatchable repr
  55   ) => CombMatchable (ObserveSharing 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 'ObserveSharing' interpreter.
  60   conditional a bs d = observeSharingNode $ ObserveSharing $ conditional
  61     F.<$> unObserveSharing a
  62     F.<*> mapM (\(p, b) -> (p,) F.<$> unObserveSharing b) bs
  63     F.<*> unObserveSharing d
  64 instance
  65   ( Referenceable TH.Name repr
  66   , CombSelectable repr
  67   ) => CombSelectable (ObserveSharing TH.Name repr)
  68 instance
  69   ( Referenceable TH.Name repr
  70   , CombSatisfiable tok repr
  71   ) => CombSatisfiable tok (ObserveSharing TH.Name repr)
  72 instance
  73   ( Referenceable TH.Name repr
  74   , CombRegisterableUnscoped repr
  75   ) => CombRegisterable (ObserveSharing TH.Name repr) where
  76   new ini f =
  77     -- 'unsafePerformIO' is used here because propagating 'IO'
  78     -- would prevent 'observeSharing' 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 x = putUnscoped (unRegister reg) x
  85 instance
  86   ( Referenceable TH.Name repr
  87   , CombRegisterableUnscoped repr
  88   ) => CombRegisterableUnscoped (ObserveSharing 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 'observeSharing'.
  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 'FinalizeSharing' interpreter.
 111 instance
 112   ( CombApplicable repr
 113   ) => CombApplicable (FinalizeSharing TH.Name repr)
 114 instance
 115   ( CombAlternable repr
 116   ) => CombAlternable (FinalizeSharing TH.Name repr)
 117 instance
 118   ( CombFoldable repr
 119   ) => CombFoldable (FinalizeSharing TH.Name repr)
 120 instance
 121   ( CombLookable repr
 122   ) => CombLookable (FinalizeSharing TH.Name repr)
 123 instance
 124   ( CombMatchable repr
 125   ) => CombMatchable (FinalizeSharing TH.Name repr) where
 126   conditional a bs d = FinalizeSharing $ conditional
 127     F.<$> unFinalizeSharing a
 128     F.<*> mapM (\(p, b) -> (p,) F.<$> unFinalizeSharing b) bs
 129     F.<*> unFinalizeSharing d
 130 instance
 131   ( CombSatisfiable tok repr
 132   ) => CombSatisfiable tok (FinalizeSharing TH.Name repr)
 133 instance
 134   ( CombSelectable repr
 135   ) => CombSelectable (FinalizeSharing TH.Name repr)
 136 instance
 137   ( CombRegisterableUnscoped repr
 138   ) => CombRegisterableUnscoped (FinalizeSharing 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]