]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Grammar/SharingObserver.hs
tests: add more tests
[haskell/symantic-parser.git] / src / Symantic / Parser / Grammar / SharingObserver.hs
1 {-# LANGUAGE DefaultSignatures #-}
2 {-# LANGUAGE TupleSections #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 module Symantic.Parser.Grammar.SharingObserver
5 ( module Symantic.Semantics.SharingObserver
6 , module Symantic.Parser.Grammar.SharingObserver
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 App
15
16 import Symantic.Parser.Grammar.Combinators
17 import Symantic.Syntaxes.Derive
18 import Symantic.Semantics.SharingObserver hiding (sharingObserver)
19 import qualified Symantic.Semantics.SharingObserver as SharingObserver
20 import qualified Language.Haskell.TH.Syntax as TH
21
22 -- | Like 'Observable.sharingObserver'
23 -- but type-binding @(letName)@ to 'TH.Name'
24 -- to avoid the trouble to always set it.
25 sharingObserver :: Letsable TH.Name repr => SharingObserver TH.Name repr a -> repr a
26 sharingObserver os = lets defs body
27 where (body, defs) = SharingObserver.sharingObserver os
28
29 -- | Needed by 'sharingObserver'.
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 'SharingObserver' interpreter.
36 instance
37 ( Referenceable TH.Name repr
38 , CombAlternable repr
39 ) => CombAlternable (SharingObserver TH.Name repr)
40 instance
41 ( Referenceable TH.Name repr
42 , CombApplicable repr
43 ) => CombApplicable (SharingObserver TH.Name repr)
44 instance
45 ( Referenceable TH.Name repr
46 , CombFoldable repr
47 ) => CombFoldable (SharingObserver TH.Name repr)
48 instance
49 ( Referenceable TH.Name repr
50 , CombLookable repr
51 ) => CombLookable (SharingObserver TH.Name repr)
52 instance
53 ( Referenceable TH.Name repr
54 , CombMatchable repr
55 ) => CombMatchable (SharingObserver 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 'SharingObserver' interpreter.
60 conditional a bs d = sharingObserverNode $ SharingObserver $ conditional
61 App.<$> unSharingObserver a
62 App.<*> mapM (\(p, b) -> (p,) App.<$> unSharingObserver b) bs
63 App.<*> unSharingObserver d
64 instance
65 ( Referenceable TH.Name repr
66 , CombSelectable repr
67 ) => CombSelectable (SharingObserver TH.Name repr)
68 instance
69 ( Referenceable TH.Name repr
70 , CombSatisfiable tok repr
71 ) => CombSatisfiable tok (SharingObserver TH.Name repr)
72 instance
73 ( Referenceable TH.Name repr
74 , CombRegisterableUnscoped repr
75 ) => CombRegisterable (SharingObserver TH.Name repr) where
76 new ini f =
77 -- 'unsafePerformIO' is used here because propagating 'IO'
78 -- would prevent 'sharingObserver' 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 = putUnscoped (unRegister reg)
85 instance
86 ( Referenceable TH.Name repr
87 , CombRegisterableUnscoped repr
88 ) => CombRegisterableUnscoped (SharingObserver 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 'sharingObserver'.
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 'SharingFinalizer' interpreter.
111 instance
112 ( CombApplicable repr
113 ) => CombApplicable (SharingFinalizer TH.Name repr)
114 instance
115 ( CombAlternable repr
116 ) => CombAlternable (SharingFinalizer TH.Name repr)
117 instance
118 ( CombFoldable repr
119 ) => CombFoldable (SharingFinalizer TH.Name repr)
120 instance
121 ( CombLookable repr
122 ) => CombLookable (SharingFinalizer TH.Name repr)
123 instance
124 ( CombMatchable repr
125 ) => CombMatchable (SharingFinalizer TH.Name repr) where
126 conditional a bs d = SharingFinalizer $ conditional
127 App.<$> unSharingFinalizer a
128 App.<*> mapM (\(p, b) -> (p,) App.<$> unSharingFinalizer b) bs
129 App.<*> unSharingFinalizer d
130 instance
131 ( CombSatisfiable tok repr
132 ) => CombSatisfiable tok (SharingFinalizer TH.Name repr)
133 instance
134 ( CombSelectable repr
135 ) => CombSelectable (SharingFinalizer TH.Name repr)
136 instance
137 ( CombRegisterableUnscoped repr
138 ) => CombRegisterableUnscoped (SharingFinalizer 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]