]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Grammar/ObserveSharing.hs
grammar: open the Comb data-type
[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.Univariant.Trans as Sym
17 import qualified Symantic.Parser.Grammar.Combinators as G
18 import qualified Language.Haskell.TH.Syntax as TH
19
20 -- | Like 'Letable.observeSharing'
21 -- but type-binding @(letName)@ to 'TH.Name' to help type inference.
22 observeSharing :: ObserveSharing TH.Name repr a -> repr a
23 observeSharing = Letable.observeSharing
24
25 instance Hashable TH.Name where
26 hashWithSalt s = hashWithSalt s . show
27
28 -- Combinators semantics for the 'ObserveSharing' interpreter
29 instance
30 ( Letable letName repr
31 , MakeLetName letName
32 , Eq letName
33 , Hashable letName
34 , G.Satisfiable tok repr
35 ) => G.Satisfiable tok (ObserveSharing letName repr)
36 instance
37 ( Letable letName repr
38 , MakeLetName letName
39 , Eq letName
40 , Hashable letName
41 , G.Alternable repr
42 ) => G.Alternable (ObserveSharing letName repr)
43 instance
44 ( Letable letName repr
45 , MakeLetName letName
46 , Eq letName
47 , Hashable letName
48 , G.Applicable repr
49 ) => G.Applicable (ObserveSharing letName repr)
50 instance
51 ( Letable letName repr
52 , MakeLetName letName
53 , Eq letName
54 , Hashable letName
55 , G.Selectable repr
56 ) => G.Selectable (ObserveSharing letName repr)
57 instance
58 ( Letable letName repr
59 , MakeLetName letName
60 , Eq letName
61 , Hashable letName
62 , G.Matchable repr
63 ) => G.Matchable (ObserveSharing letName repr) where
64 -- Here the default definition does not fit
65 -- since there is no lift* for the type of 'conditional'
66 -- and its default definition does not handles 'bs'
67 -- as needed by the 'ObserveSharing' transformation.
68 conditional a cs bs b = observeSharingNode $ ObserveSharing $
69 G.conditional
70 <$> unObserveSharing a
71 <*> pure cs
72 <*> mapM unObserveSharing bs
73 <*> unObserveSharing b
74 instance
75 ( Letable letName repr
76 , MakeLetName letName
77 , Eq letName
78 , Hashable letName
79 , G.Foldable repr
80 {- TODO: the following constraints are for the current Foldable,
81 - they will have to be removed when Foldable will have Sym.lift2 as defaults
82 -}
83 , G.Applicable repr
84 , G.Alternable repr
85 ) => G.Foldable (ObserveSharing letName repr)
86 instance
87 ( Letable letName repr
88 , MakeLetName letName
89 , Eq letName
90 , Hashable letName
91 , G.Lookable repr
92 ) => G.Lookable (ObserveSharing letName repr)
93
94 -- Combinators semantics for the 'CleanDefs' interpreter
95 instance G.Applicable repr => G.Applicable (CleanDefs letName repr)
96 instance G.Alternable repr => G.Alternable (CleanDefs letName repr)
97 instance G.Satisfiable tok repr => G.Satisfiable tok (CleanDefs letName repr)
98 instance G.Selectable repr => G.Selectable (CleanDefs letName repr)
99 instance G.Matchable repr => G.Matchable (CleanDefs letName repr) where
100 conditional a cs bs b = CleanDefs $
101 G.conditional
102 <$> unCleanDefs a
103 <*> pure cs
104 <*> mapM unCleanDefs bs
105 <*> unCleanDefs b
106 instance G.Lookable repr => G.Lookable (CleanDefs letName repr)
107 instance G.Foldable repr => G.Foldable (CleanDefs letName repr) where
108 chainPre = Sym.lift2 G.chainPre
109 chainPost = Sym.lift2 G.chainPost