{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.Parser.Grammar.ObserveSharing
- ( Symantic.Parser.Grammar.ObserveSharing.observeSharing
- ) where
+ ( module Symantic.Univariant.Letable
+ , 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 Text.Show (Show(..))
+import qualified Control.Applicative as Functor
-import Symantic.Univariant.Letable as Letable
-import qualified Symantic.Parser.Grammar.Combinators as Comb
+import Symantic.Parser.Grammar.Combinators
+import Symantic.Univariant.Letable hiding (observeSharing)
+import qualified Symantic.Univariant.Letable as Letable
import qualified Language.Haskell.TH.Syntax as TH
+import qualified Symantic.Univariant.Trans as Sym
--- | Like 'Letable.observeSharing' but type-binding @(letName)@ to 'TH.Name' to help type inference.
-observeSharing :: ObserveSharing TH.Name repr a -> IO (repr a)
+-- | Like 'Letable.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
+-- | Needed by 'observeSharing'.
instance Hashable TH.Name where
hashWithSalt s = hashWithSalt s . show
--- Combinators semantics for the 'ObserveSharing' interpreter
+-- Combinators semantics for the 'ObserveSharing' interpreter.
instance
( Letable letName repr
, MakeLetName letName
, Eq letName
, Hashable letName
- , Comb.Charable repr
- ) => Comb.Charable (ObserveSharing letName repr)
+ , Satisfiable tok repr
+ ) => Satisfiable tok (ObserveSharing letName repr)
instance
( Letable letName repr
, MakeLetName letName
, Eq letName
, Hashable letName
- , Comb.Alternable repr
- ) => Comb.Alternable (ObserveSharing letName repr)
+ , Alternable repr
+ ) => Alternable (ObserveSharing letName repr)
instance
( Letable letName repr
, MakeLetName letName
, Eq letName
, Hashable letName
- , Comb.Applicable repr
- ) => Comb.Applicable (ObserveSharing letName repr)
+ , Applicable repr
+ ) => Applicable (ObserveSharing letName repr)
instance
( Letable letName repr
, MakeLetName letName
, Eq letName
, Hashable letName
- , Comb.Selectable repr
- ) => Comb.Selectable (ObserveSharing letName repr)
+ , Selectable repr
+ ) => 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
+ , Matchable repr
+ ) => Matchable (ObserveSharing letName 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'
+ -- 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 letName repr
, MakeLetName letName
, Eq letName
, Hashable letName
- , Comb.Foldable repr
- ) => Comb.Foldable (ObserveSharing letName 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 letName repr)
instance
( Letable letName repr
, MakeLetName letName
, Eq letName
, Hashable letName
- , Comb.Lookable repr
- ) => Comb.Lookable (ObserveSharing letName repr)
+ , Lookable repr
+ ) => Lookable (ObserveSharing letName 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)
+-- 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 $
+ conditional
+ Functor.<$> unCleanDefs 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
sourcephile / git / haskell / symantic-parser.git / blobdiff