]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Grammar/ObserveSharing.hs
Polish code and dumps
[haskell/symantic-parser.git] / src / Symantic / Parser / Grammar / ObserveSharing.hs
1 {-# OPTIONS_GHC -fno-warn-orphans #-}
2 module Symantic.Parser.Grammar.ObserveSharing
3 ( module Symantic.Parser.Grammar.ObserveSharing
4 , ObserveSharing(..)
5 ) where
6
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(..))
14
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
18
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
22
23 instance Hashable TH.Name where
24 hashWithSalt s = hashWithSalt s . show
25
26 -- Combinators semantics for the 'ObserveSharing' interpreter
27 instance
28 ( Letable letName repr
29 , MakeLetName letName
30 , Eq letName
31 , Hashable letName
32 , Comb.Charable repr
33 ) => Comb.Charable (ObserveSharing letName repr)
34 instance
35 ( Letable letName repr
36 , MakeLetName letName
37 , Eq letName
38 , Hashable letName
39 , Comb.Alternable repr
40 ) => Comb.Alternable (ObserveSharing letName repr)
41 instance
42 ( Letable letName repr
43 , MakeLetName letName
44 , Eq letName
45 , Hashable letName
46 , Comb.Applicable repr
47 ) => Comb.Applicable (ObserveSharing letName repr)
48 instance
49 ( Letable letName repr
50 , MakeLetName letName
51 , Eq letName
52 , Hashable letName
53 , Comb.Selectable repr
54 ) => Comb.Selectable (ObserveSharing letName repr)
55 instance
56 ( Letable letName repr
57 , MakeLetName letName
58 , Eq letName
59 , Hashable letName
60 , Comb.Matchable 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 $
65 Comb.conditional cs
66 <$> mapM unObserveSharing bs
67 <*> unObserveSharing a
68 <*> unObserveSharing b
69 instance
70 ( Letable letName repr
71 , MakeLetName letName
72 , Eq letName
73 , Hashable letName
74 , Comb.Foldable repr
75 ) => Comb.Foldable (ObserveSharing letName repr)
76 instance
77 ( Letable letName repr
78 , MakeLetName letName
79 , Eq letName
80 , Hashable letName
81 , Comb.Lookable repr
82 ) => Comb.Lookable (ObserveSharing letName repr)
83
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 $
91 Comb.conditional cs
92 <$> mapM unCleanDefs bs
93 <*> unCleanDefs a
94 <*> unCleanDefs b
95 instance Comb.Lookable repr => Comb.Lookable (CleanDefs letName repr)
96 instance Comb.Foldable repr => Comb.Foldable (CleanDefs letName repr)