{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.Parser.Grammar.ObserveSharing
- ( module Symantic.Univariant.Letable
+ ( module Symantic.Typed.ObserveSharing
, module Symantic.Parser.Grammar.ObserveSharing
) where
import Control.Monad (mapM)
-import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Hashable (Hashable, hashWithSalt)
import Text.Show (Show(..))
import qualified Control.Applicative as Functor
import Symantic.Parser.Grammar.Combinators
-import Symantic.Univariant.Letable hiding (observeSharing)
-import qualified Symantic.Univariant.Letable as Letable
+import Symantic.Typed.Derive
+import Symantic.Typed.ObserveSharing hiding (observeSharing)
+import qualified Symantic.Typed.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 :: ObserveSharing TH.Name repr a -> repr a
-observeSharing = Letable.observeSharing
+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 TH.Name repr, CombAlternable repr) =>
+ CombAlternable (ObserveSharing TH.Name repr)
+instance (Letable TH.Name repr, CombApplicable repr) =>
+ CombApplicable (ObserveSharing TH.Name repr)
instance
- ( Letable letName repr
- , MakeLetName letName
- , Eq letName
- , Hashable letName
- , Show letName
- , Satisfiable tok repr
- ) => Satisfiable tok (ObserveSharing letName repr)
-instance
- ( Letable letName repr
- , MakeLetName letName
- , Eq letName
- , Hashable letName
- , Show letName
- , Alternable repr
- ) => Alternable (ObserveSharing letName repr)
-instance
- ( Letable letName repr
- , MakeLetName letName
- , Eq letName
- , Hashable letName
- , Show letName
- , Applicable repr
- ) => Applicable (ObserveSharing letName repr)
-instance
- ( Letable letName repr
- , MakeLetName letName
- , Eq letName
- , Hashable letName
- , Show letName
- , Selectable repr
- ) => Selectable (ObserveSharing letName repr)
-instance
- ( Letable letName repr
- , MakeLetName letName
- , Eq letName
- , Hashable letName
- , Show letName
- , Matchable repr
- ) => Matchable (ObserveSharing letName repr) where
+ ( Letable TH.Name repr
+ , CombFoldable repr
+ {- TODO: the following constraints are for the current CombFoldable,
+ - they will have to be removed when CombFoldable will have 'liftDerived2' as defaults
+ -}
+ , CombApplicable repr
+ , CombAlternable repr
+ ) => CombFoldable (ObserveSharing TH.Name repr)
+instance (Letable TH.Name repr, CombLookable repr) =>
+ CombLookable (ObserveSharing TH.Name repr)
+instance (Letable 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'
-- and its default definition does not handles 'bs'
Functor.<*> Functor.pure cs
Functor.<*> mapM unObserveSharing bs
Functor.<*> unObserveSharing b
-instance
- ( Letable letName repr
- , MakeLetName letName
- , Eq letName
- , Hashable letName
- , Show letName
- , 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 letName repr)
-instance
- ( Letable letName repr
- , MakeLetName letName
- , Eq letName
- , Hashable letName
- , Show letName
- , Lookable repr
- ) => Lookable (ObserveSharing letName repr)
+instance (Letable TH.Name repr, CombSelectable repr) =>
+ CombSelectable (ObserveSharing TH.Name repr)
+instance (Letable TH.Name repr, CombSatisfiable tok repr) =>
+ CombSatisfiable tok (ObserveSharing TH.Name repr)
--- Combinators semantics for the 'CleanDefs' interpreter.
-instance Applicable repr => Applicable (CleanDefs letName repr)
-instance Alternable repr => Alternable (CleanDefs letName repr)
-instance Satisfiable tok repr => Satisfiable tok (CleanDefs letName repr)
-instance Selectable repr => Selectable (CleanDefs letName repr)
-instance Matchable repr => Matchable (CleanDefs letName repr) where
- conditional a cs bs b = CleanDefs $
+-- 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) where
+ chainPre = liftDerived2 chainPre
+ chainPost = liftDerived2 chainPost
+instance CombLookable repr => CombLookable (FinalizeSharing TH.Name repr)
+instance CombMatchable repr => CombMatchable (FinalizeSharing TH.Name repr) where
+ conditional a cs bs b = FinalizeSharing $
conditional
- Functor.<$> unCleanDefs a
+ Functor.<$> unFinalizeSharing a
Functor.<*> Functor.pure cs
- Functor.<*> mapM unCleanDefs bs
- Functor.<*> unCleanDefs b
-instance Lookable repr => Lookable (CleanDefs letName repr)
-instance Foldable repr => Foldable (CleanDefs letName repr) where
- chainPre = Sym.lift2 chainPre
- chainPost = Sym.lift2 chainPost
+ Functor.<*> mapM unFinalizeSharing bs
+ Functor.<*> unFinalizeSharing b
+instance CombSatisfiable tok repr => CombSatisfiable tok (FinalizeSharing TH.Name repr)
+instance CombSelectable repr => CombSelectable (FinalizeSharing TH.Name repr)
sourcephile / git / haskell / symantic-parser.git / blobdiff