]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Grammar/ObserveSharing.hs
doc: fix typos
[haskell/symantic-parser.git] / src / Symantic / Parser / Grammar / ObserveSharing.hs
1 {-# LANGUAGE DefaultSignatures #-}
2 {-# LANGUAGE TupleSections #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 module Symantic.Parser.Grammar.ObserveSharing
5 ( module Symantic.ObserveSharing
6 , module Symantic.Parser.Grammar.ObserveSharing
7 ) where
8
9 import Control.Monad (mapM)
10 import Data.Function (($), (.))
11 import Data.Hashable (Hashable, hashWithSalt)
12 import System.IO.Unsafe (unsafePerformIO) -- For 'new'
13 import Text.Show (Show(..))
14 import qualified Control.Applicative as F
15
16 import Symantic.Parser.Grammar.Combinators
17 import Symantic.Derive
18 import Symantic.ObserveSharing hiding (observeSharing)
19 import qualified Symantic.ObserveSharing as ObserveSharing
20 import qualified Language.Haskell.TH.Syntax as TH
21
22 -- | Like 'Observable.observeSharing'
23 -- but type-binding @(letName)@ to 'TH.Name'
24 -- to avoid the trouble to always set it.
25 observeSharing :: Letsable TH.Name repr => ObserveSharing TH.Name repr a -> repr a
26 observeSharing os = lets defs body
27 where (body, defs) = ObserveSharing.observeSharing os
28
29 -- | Needed by 'observeSharing'.
30 instance Hashable TH.Name where
31 hashWithSalt s = hashWithSalt s . show
32 instance MakeLetName TH.Name where
33 makeLetName _ = TH.qNewName "name"
34
35 -- Combinators semantics for the 'ObserveSharing' interpreter.
36 instance
37 ( Referenceable TH.Name repr
38 , CombAlternable repr
39 ) => CombAlternable (ObserveSharing TH.Name repr)
40 instance
41 ( Referenceable TH.Name repr
42 , CombApplicable repr
43 ) => CombApplicable (ObserveSharing TH.Name repr)
44 instance
45 ( Referenceable TH.Name repr
46 , CombFoldable repr
47 ) => CombFoldable (ObserveSharing TH.Name repr)
48 instance
49 ( Referenceable TH.Name repr
50 , CombLookable repr
51 ) => CombLookable (ObserveSharing TH.Name repr)
52 instance
53 ( Referenceable TH.Name repr
54 , CombMatchable repr
55 ) => CombMatchable (ObserveSharing TH.Name repr) where
56 -- Here the default definition does not fit
57 -- since there is no liftDerived* for the type of 'conditional'
58 -- and its default definition does not handles 'bs'
59 -- as needed by the 'ObserveSharing' interpreter.
60 conditional a bs d = observeSharingNode $ ObserveSharing $ conditional
61 F.<$> unObserveSharing a
62 F.<*> mapM (\(p, b) -> (p,) F.<$> unObserveSharing b) bs
63 F.<*> unObserveSharing d
64 instance
65 ( Referenceable TH.Name repr
66 , CombSelectable repr
67 ) => CombSelectable (ObserveSharing TH.Name repr)
68 instance
69 ( Referenceable TH.Name repr
70 , CombSatisfiable tok repr
71 ) => CombSatisfiable tok (ObserveSharing TH.Name repr)
72 instance
73 ( Referenceable TH.Name repr
74 , CombRegisterableUnscoped repr
75 ) => CombRegisterable (ObserveSharing TH.Name repr) where
76 new ini f =
77 -- 'unsafePerformIO' is used here because propagating 'IO'
78 -- would prevent 'observeSharing' to recognize recursive let,
79 -- causing an infinite loop on them.
80 let !regName = unsafePerformIO $ TH.newName "reg" in
81 let reg = UnscopedRegister regName in
82 newUnscoped reg ini (f (Register reg))
83 get = getUnscoped . unRegister
84 put reg x = putUnscoped (unRegister reg) x
85 instance
86 ( Referenceable TH.Name repr
87 , CombRegisterableUnscoped repr
88 ) => CombRegisterableUnscoped (ObserveSharing TH.Name repr)
89
90 -- * Class 'CombRegisterableUnscoped'
91 -- | These combinators are used to remove the @Rank2Types@ from 'CombRegisterable'
92 -- in order to be able to 'observeSharing'.
93 class CombRegisterableUnscoped (repr::ReprComb) where
94 newUnscoped :: UnscopedRegister a -> repr a -> repr b -> repr b
95 getUnscoped :: UnscopedRegister a -> repr a
96 putUnscoped :: UnscopedRegister a -> repr a -> repr ()
97 default newUnscoped ::
98 FromDerived2 CombRegisterableUnscoped repr =>
99 UnscopedRegister a -> repr a -> repr b -> repr b
100 default getUnscoped ::
101 FromDerived CombRegisterableUnscoped repr =>
102 UnscopedRegister a -> repr a
103 default putUnscoped ::
104 FromDerived1 CombRegisterableUnscoped repr =>
105 UnscopedRegister a -> repr a -> repr ()
106 newUnscoped = liftDerived2 . newUnscoped
107 getUnscoped = liftDerived . getUnscoped
108 putUnscoped = liftDerived1 . putUnscoped
109
110 -- Combinators semantics for the 'FinalizeSharing' interpreter.
111 instance
112 ( CombApplicable repr
113 ) => CombApplicable (FinalizeSharing TH.Name repr)
114 instance
115 ( CombAlternable repr
116 ) => CombAlternable (FinalizeSharing TH.Name repr)
117 instance
118 ( CombFoldable repr
119 ) => CombFoldable (FinalizeSharing TH.Name repr)
120 instance
121 ( CombLookable repr
122 ) => CombLookable (FinalizeSharing TH.Name repr)
123 instance
124 ( CombMatchable repr
125 ) => CombMatchable (FinalizeSharing TH.Name repr) where
126 conditional a bs d = FinalizeSharing $ conditional
127 F.<$> unFinalizeSharing a
128 F.<*> mapM (\(p, b) -> (p,) F.<$> unFinalizeSharing b) bs
129 F.<*> unFinalizeSharing d
130 instance
131 ( CombSatisfiable tok repr
132 ) => CombSatisfiable tok (FinalizeSharing TH.Name repr)
133 instance
134 ( CombSelectable repr
135 ) => CombSelectable (FinalizeSharing TH.Name repr)
136 instance
137 ( CombRegisterableUnscoped repr
138 ) => CombRegisterableUnscoped (FinalizeSharing TH.Name repr)
139
140 -- | Call trace stack updated by 'call' and 'refJoin'.
141 -- Used to avoid infinite loops when tying the knot with 'polyfix'.
142 type CallTrace = [TH.Name]