+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.Parser.Grammar.ObserveSharing
- ( module Symantic.Parser.Grammar.ObserveSharing
- , ObserveSharing(..)
- ) where
+ ( module Symantic.ObserveSharing
+ , module Symantic.Parser.Grammar.ObserveSharing
+ ) where
import Control.Monad (mapM)
-import Control.Applicative (Applicative(..))
-import Data.Eq (Eq(..))
import Data.Function (($), (.))
-import Data.Functor ((<$>))
import Data.Hashable (Hashable, hashWithSalt)
-import System.IO (IO)
+import System.IO.Unsafe (unsafePerformIO) -- For 'new'
import Text.Show (Show(..))
+import qualified Control.Applicative as F
-import Symantic.Univariant.Letable as Letable
-import qualified Symantic.Parser.Grammar.Combinators as Comb
+import Symantic.Parser.Grammar.Combinators
+import Symantic.Derive
+import Symantic.ObserveSharing hiding (observeSharing)
+import qualified Symantic.ObserveSharing as ObserveSharing
import qualified Language.Haskell.TH.Syntax as TH
--- | Like 'Letable.observeSharing' but type-binding @(letName)@ to 'TH.Name' to help type inference.
-observeSharing :: ObserveSharing TH.Name repr a -> IO (repr a)
-observeSharing = 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 os = lets defs body
+ where (body, defs) = ObserveSharing.observeSharing os
+-- | Needed by 'observeSharing'.
instance Hashable TH.Name where
hashWithSalt s = hashWithSalt s . show
+instance MakeLetName TH.Name where
+ makeLetName _ = TH.qNewName "name"
--- Combinators semantics for the 'ObserveSharing' interpreter
-instance
- ( Letable letName repr
- , MakeLetName letName
- , Eq letName
- , Hashable letName
- , Comb.Charable repr
- ) => Comb.Charable (ObserveSharing letName repr)
-instance
- ( Letable letName repr
- , MakeLetName letName
- , Eq letName
- , Hashable letName
- , Comb.Alternable repr
- ) => Comb.Alternable (ObserveSharing letName repr)
-instance
- ( Letable letName repr
- , MakeLetName letName
- , Eq letName
- , Hashable letName
- , Comb.Applicable repr
- ) => Comb.Applicable (ObserveSharing letName repr)
-instance
- ( Letable letName repr
- , MakeLetName letName
- , Eq letName
- , Hashable letName
- , Comb.Selectable repr
- ) => Comb.Selectable (ObserveSharing letName repr)
-instance
- ( Letable letName repr
- , MakeLetName letName
- , Eq letName
- , Hashable letName
- , Comb.Matchable repr
- ) => Comb.Matchable (ObserveSharing letName repr) where
- -- Here the default definition does not fit since there is no lift* for its type and thus handles 'bs' itself,
- -- which is not the transformation wanted.
- conditional cs bs a b = observeSharingNode $ ObserveSharing $
- Comb.conditional cs
- <$> mapM unObserveSharing bs
- <*> unObserveSharing a
- <*> unObserveSharing b
-instance
- ( Letable letName repr
- , MakeLetName letName
- , Eq letName
- , Hashable letName
- , Comb.Foldable repr
- ) => Comb.Foldable (ObserveSharing letName repr)
-instance
- ( Letable letName repr
- , MakeLetName letName
- , Eq letName
- , Hashable letName
- , Comb.Lookable repr
- ) => Comb.Lookable (ObserveSharing letName repr)
+-- Combinators semantics for the 'ObserveSharing' interpreter.
+instance
+ ( Referenceable TH.Name repr
+ , CombAlternable repr
+ ) => CombAlternable (ObserveSharing TH.Name repr)
+instance
+ ( Referenceable TH.Name repr
+ , CombApplicable repr
+ ) => CombApplicable (ObserveSharing TH.Name repr)
+instance
+ ( Referenceable TH.Name repr
+ , CombFoldable repr
+ ) => CombFoldable (ObserveSharing TH.Name repr)
+instance
+ ( Referenceable TH.Name repr
+ , CombLookable repr
+ ) => CombLookable (ObserveSharing TH.Name repr)
+instance
+ ( Referenceable TH.Name repr
+ , CombMatchable repr
+ ) => CombMatchable (ObserveSharing TH.Name repr) where
+ -- Here the default definition does not fit
+ -- since there is no liftDerived* for the type of 'conditional'
+ -- and its default definition does not handles 'bs'
+ -- 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
+ ( 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)
--- Combinators semantics for the 'CleanDefs' interpreter
-instance Comb.Applicable repr => Comb.Applicable (CleanDefs letName repr)
-instance Comb.Alternable repr => Comb.Alternable (CleanDefs letName repr)
-instance Comb.Charable repr => Comb.Charable (CleanDefs letName repr)
-instance Comb.Selectable repr => Comb.Selectable (CleanDefs letName repr)
-instance Comb.Matchable repr => Comb.Matchable (CleanDefs letName repr) where
- conditional cs bs a b = CleanDefs $
- Comb.conditional cs
- <$> mapM unCleanDefs bs
- <*> unCleanDefs a
- <*> unCleanDefs b
-instance Comb.Lookable repr => Comb.Lookable (CleanDefs letName repr)
-instance Comb.Foldable repr => Comb.Foldable (CleanDefs letName 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