+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.Parser.Grammar.ObserveSharing
- ( module Symantic.Univariant.Letable
+ ( module Symantic.ObserveSharing
, module Symantic.Parser.Grammar.ObserveSharing
) where
import Control.Monad (mapM)
import Data.Function (($), (.))
import Data.Hashable (Hashable, hashWithSalt)
+import System.IO.Unsafe (unsafePerformIO) -- For 'new'
import Text.Show (Show(..))
-import qualified Control.Applicative as Functor
+import qualified Control.Applicative as F
import Symantic.Parser.Grammar.Combinators
-import Symantic.Univariant.Letable hiding (observeSharing)
-import qualified Symantic.Univariant.Letable as Letable
+import Symantic.Derive
+import Symantic.ObserveSharing hiding (observeSharing)
+import qualified Symantic.ObserveSharing as ObserveSharing
import qualified Language.Haskell.TH.Syntax as TH
-import qualified Symantic.Univariant.Trans as Sym
--- | Like 'Letable.observeSharing'
+-- | Like 'Observable.observeSharing'
-- but type-binding @(letName)@ to 'TH.Name'
-- to avoid the trouble to always set it.
-observeSharing ::
- Letsable TH.Name repr =>
- ObserveSharing TH.Name repr a ->
- repr a
+observeSharing :: Letsable TH.Name repr => ObserveSharing TH.Name repr a -> repr a
observeSharing os = lets defs body
- where (body, defs) = Letable.observeSharing os
+ where (body, defs) = ObserveSharing.observeSharing os
-- | Needed by 'observeSharing'.
instance Hashable TH.Name where
-- Combinators semantics for the 'ObserveSharing' interpreter.
instance
- ( Letable TH.Name repr
- , Satisfiable tok repr
- ) => Satisfiable tok (ObserveSharing TH.Name repr)
+ ( Referenceable TH.Name repr
+ , CombAlternable repr
+ ) => CombAlternable (ObserveSharing TH.Name repr)
instance
- ( Letable TH.Name repr
- , Alternable repr
- ) => Alternable (ObserveSharing TH.Name repr)
+ ( Referenceable TH.Name repr
+ , CombApplicable repr
+ ) => CombApplicable (ObserveSharing TH.Name repr)
instance
- ( Letable TH.Name repr
- , Applicable repr
- ) => Applicable (ObserveSharing TH.Name repr)
+ ( Referenceable TH.Name repr
+ , CombFoldable repr
+ ) => CombFoldable (ObserveSharing TH.Name repr)
instance
- ( Letable TH.Name repr
- , Selectable repr
- ) => Selectable (ObserveSharing TH.Name repr)
+ ( Referenceable TH.Name repr
+ , CombLookable repr
+ ) => CombLookable (ObserveSharing TH.Name repr)
instance
- ( Letable TH.Name repr
- , Matchable repr
- ) => Matchable (ObserveSharing TH.Name repr) where
+ ( Referenceable TH.Name repr
+ , CombMatchable repr
+ ) => CombMatchable (ObserveSharing TH.Name repr) where
-- Here the default definition does not fit
- -- since there is no lift* for the type of 'conditional'
+ -- since there is no liftDerived* for the type of 'conditional'
-- and its default definition does not handles 'bs'
- -- as needed by the 'ObserveSharing' transformation.
- conditional a cs bs b = observeSharingNode $ ObserveSharing $
- conditional
- Functor.<$> unObserveSharing a
- Functor.<*> Functor.pure cs
- Functor.<*> mapM unObserveSharing bs
- Functor.<*> unObserveSharing b
-instance
- ( Letable TH.Name repr
- , Foldable repr
- {- TODO: the following constraints are for the current Foldable,
- - they will have to be removed when Foldable will have Sym.lift2 as defaults
- -}
- , Applicable repr
- , Alternable repr
- ) => Foldable (ObserveSharing TH.Name repr)
-instance
- ( Letable TH.Name repr
- , Lookable repr
- ) => Lookable (ObserveSharing TH.Name repr)
+ -- as needed by the 'ObserveSharing' interpreter.
+ conditional a bs d = observeSharingNode $ ObserveSharing $ conditional
+ F.<$> unObserveSharing a
+ F.<*> mapM (\(p, b) -> (p,) F.<$> unObserveSharing b) bs
+ F.<*> unObserveSharing d
+instance
+ ( Referenceable TH.Name repr
+ , CombSelectable repr
+ ) => CombSelectable (ObserveSharing TH.Name repr)
+instance
+ ( Referenceable TH.Name repr
+ , CombSatisfiable tok repr
+ ) => CombSatisfiable tok (ObserveSharing TH.Name repr)
+instance
+ ( Referenceable TH.Name repr
+ , CombRegisterableUnscoped repr
+ ) => CombRegisterable (ObserveSharing TH.Name repr) where
+ new ini f =
+ -- 'unsafePerformIO' is used here because propagating 'IO'
+ -- would prevent 'observeSharing' to recognize recursive let,
+ -- causing an infinite loop on them.
+ let !regName = unsafePerformIO $ TH.newName "reg" in
+ let reg = UnscopedRegister regName in
+ newUnscoped reg ini (f (Register reg))
+ get = getUnscoped . unRegister
+ put reg x = putUnscoped (unRegister reg) x
+instance
+ ( Referenceable TH.Name repr
+ , CombRegisterableUnscoped repr
+ ) => CombRegisterableUnscoped (ObserveSharing TH.Name repr)
+
+-- * Class 'CombRegisterableUnscoped'
+-- | These combinators are used to remove the @Rank2Types@ from 'CombRegisterable'
+-- in order to be able to 'observeSharing'.
+class CombRegisterableUnscoped (repr::ReprComb) where
+ newUnscoped :: UnscopedRegister a -> repr a -> repr b -> repr b
+ getUnscoped :: UnscopedRegister a -> repr a
+ putUnscoped :: UnscopedRegister a -> repr a -> repr ()
+ default newUnscoped ::
+ FromDerived2 CombRegisterableUnscoped repr =>
+ UnscopedRegister a -> repr a -> repr b -> repr b
+ default getUnscoped ::
+ FromDerived CombRegisterableUnscoped repr =>
+ UnscopedRegister a -> repr a
+ default putUnscoped ::
+ FromDerived1 CombRegisterableUnscoped repr =>
+ UnscopedRegister a -> repr a -> repr ()
+ newUnscoped = liftDerived2 . newUnscoped
+ getUnscoped = liftDerived . getUnscoped
+ putUnscoped = liftDerived1 . putUnscoped
-- Combinators semantics for the 'FinalizeSharing' interpreter.
-instance Applicable repr => Applicable (FinalizeSharing TH.Name repr)
-instance Alternable repr => Alternable (FinalizeSharing TH.Name repr)
-instance Satisfiable tok repr => Satisfiable tok (FinalizeSharing TH.Name repr)
-instance Selectable repr => Selectable (FinalizeSharing TH.Name repr)
-instance Matchable repr => Matchable (FinalizeSharing TH.Name repr) where
- conditional a cs bs b = FinalizeSharing $
- conditional
- Functor.<$> unFinalizeSharing a
- Functor.<*> Functor.pure cs
- Functor.<*> mapM unFinalizeSharing bs
- Functor.<*> unFinalizeSharing b
-instance Lookable repr => Lookable (FinalizeSharing TH.Name repr)
-instance Foldable repr => Foldable (FinalizeSharing TH.Name repr) where
- chainPre = Sym.lift2 chainPre
- chainPost = Sym.lift2 chainPost
+instance
+ ( CombApplicable repr
+ ) => CombApplicable (FinalizeSharing TH.Name repr)
+instance
+ ( CombAlternable repr
+ ) => CombAlternable (FinalizeSharing TH.Name repr)
+instance
+ ( CombFoldable repr
+ ) => CombFoldable (FinalizeSharing TH.Name repr)
+instance
+ ( CombLookable repr
+ ) => CombLookable (FinalizeSharing TH.Name repr)
+instance
+ ( CombMatchable repr
+ ) => CombMatchable (FinalizeSharing TH.Name repr) where
+ conditional a bs d = FinalizeSharing $ conditional
+ F.<$> unFinalizeSharing a
+ F.<*> mapM (\(p, b) -> (p,) F.<$> unFinalizeSharing b) bs
+ F.<*> unFinalizeSharing d
+instance
+ ( CombSatisfiable tok repr
+ ) => CombSatisfiable tok (FinalizeSharing TH.Name repr)
+instance
+ ( CombSelectable repr
+ ) => CombSelectable (FinalizeSharing TH.Name repr)
+instance
+ ( CombRegisterableUnscoped repr
+ ) => CombRegisterableUnscoped (FinalizeSharing TH.Name repr)
+
+-- | Call trace stack updated by 'call' and 'refJoin'.
+-- Used to avoid infinite loops when tying the knot with 'polyfix'.
+type CallTrace = [TH.Name]
sourcephile / git / haskell / symantic-parser.git / blobdiff