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