1 {-# OPTIONS_GHC -fno-warn-orphans #-}
2 module Symantic.Parser.Grammar.ObserveSharing
3 ( module Symantic.Parser.Grammar.ObserveSharing
7 import Control.Monad (mapM)
8 import Control.Applicative (Applicative(..))
9 import Data.Eq (Eq(..))
10 import Data.Function (($), (.))
11 import Data.Functor ((<$>))
12 import Data.Hashable (Hashable, hashWithSalt)
13 import Text.Show (Show(..))
15 import Symantic.Univariant.Letable as Letable
16 import qualified Symantic.Parser.Grammar.Combinators as Comb
17 import qualified Language.Haskell.TH.Syntax as TH
19 -- | Like 'Letable.observeSharing' but type-binding @(letName)@ to 'TH.Name' to help type inference.
20 observeSharing :: ObserveSharing TH.Name repr a -> repr a
21 observeSharing = Letable.observeSharing
23 instance Hashable TH.Name where
24 hashWithSalt s = hashWithSalt s . show
26 -- Combinators semantics for the 'ObserveSharing' interpreter
28 ( Letable letName repr
33 ) => Comb.Charable (ObserveSharing letName repr)
35 ( Letable letName repr
39 , Comb.Alternable repr
40 ) => Comb.Alternable (ObserveSharing letName repr)
42 ( Letable letName repr
46 , Comb.Applicable repr
47 ) => Comb.Applicable (ObserveSharing letName repr)
49 ( Letable letName repr
53 , Comb.Selectable repr
54 ) => Comb.Selectable (ObserveSharing letName repr)
56 ( Letable letName repr
61 ) => Comb.Matchable (ObserveSharing letName repr) where
62 -- Here the default definition does not fit since there is no lift* for its type and thus handles 'bs' itself,
63 -- which is not the transformation wanted.
64 conditional cs bs a b = observeSharingNode $ ObserveSharing $
66 <$> mapM unObserveSharing bs
67 <*> unObserveSharing a
68 <*> unObserveSharing b
70 ( Letable letName repr
75 ) => Comb.Foldable (ObserveSharing letName repr)
77 ( Letable letName repr
82 ) => Comb.Lookable (ObserveSharing letName repr)
84 -- Combinators semantics for the 'CleanDefs' interpreter
85 instance Comb.Applicable repr => Comb.Applicable (CleanDefs letName repr)
86 instance Comb.Alternable repr => Comb.Alternable (CleanDefs letName repr)
87 instance Comb.Charable repr => Comb.Charable (CleanDefs letName repr)
88 instance Comb.Selectable repr => Comb.Selectable (CleanDefs letName repr)
89 instance Comb.Matchable repr => Comb.Matchable (CleanDefs letName repr) where
90 conditional cs bs a b = CleanDefs $
92 <$> mapM unCleanDefs bs
95 instance Comb.Lookable repr => Comb.Lookable (CleanDefs letName repr)
96 instance Comb.Foldable repr => Comb.Foldable (CleanDefs letName repr)