]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Typed/Letable.hs
rename Symantic.{Univariant => Typed}
[haskell/symantic-parser.git] / src / Symantic / Typed / Letable.hs
1 {-# LANGUAGE AllowAmbiguousTypes #-} -- For ShowLetName
2 {-# LANGUAGE DefaultSignatures #-}
3 {-# LANGUAGE ExistentialQuantification #-} -- For SharingName
4 -- {-# LANGUAGE MagicHash #-} -- For unsafeCoerce#
5 module Symantic.Typed.Letable where
6
7 import Control.Applicative (Applicative(..))
8 import Control.Monad (Monad(..))
9 import Data.Bool (Bool(..))
10 import Data.Eq (Eq(..))
11 import Data.Foldable (foldMap)
12 import Data.Function (($), (.))
13 import Data.Functor ((<$>))
14 import Data.Functor.Compose (Compose(..))
15 import Data.HashMap.Strict (HashMap)
16 import Data.HashSet (HashSet)
17 import Data.Hashable (Hashable, hashWithSalt, hash)
18 import Data.Int (Int)
19 import Data.Maybe (Maybe(..), isNothing)
20 import Data.Monoid (Monoid(..))
21 import Data.Ord (Ord(..))
22 import Data.String (String)
23 -- import GHC.Exts (Int(..))
24 -- import GHC.Prim (unsafeCoerce#)
25 import GHC.StableName (StableName(..), makeStableName, hashStableName, eqStableName)
26 -- import Numeric (showHex)
27 import Prelude ((+), error)
28 import System.IO (IO)
29 import System.IO.Unsafe (unsafePerformIO)
30 import Text.Show (Show(..))
31 import qualified Control.Monad.Trans.Class as MT
32 import qualified Control.Monad.Trans.Reader as MT
33 import qualified Control.Monad.Trans.State as MT
34 import qualified Control.Monad.Trans.Writer as MT
35 import qualified Data.HashMap.Strict as HM
36 import qualified Data.HashSet as HS
37
38 import Symantic.Typed.Trans
39
40 --import Debug.Trace (trace)
41
42 -- * Class 'Letable'
43 -- | This class is not for end-users like usual symantic operators,
44 -- here 'shareable' and 'ref' are introduced by 'observeSharing'.
45 class Letable letName repr where
46 -- | @('ref' isRec letName)@ is a reference to @(letName)@.
47 -- @(isRec)@ is 'True' iif. this 'ref'erence is recursive,
48 -- ie. is reachable within its 'def'inition.
49 ref :: Bool -> letName -> repr a
50 default ref ::
51 Liftable repr => Letable letName (Output repr) =>
52 Bool -> letName -> repr a
53 ref isRec n = lift (ref isRec n)
54
55 -- | @('shareable' letName x)@ let-binds @(letName)@ to be equal to @(x)@.
56 shareable :: letName -> repr a -> repr a
57 default shareable ::
58 Liftable1 repr => Letable letName (Output repr) =>
59 letName -> repr a -> repr a
60 shareable n = lift1 (shareable n)
61
62 -- * Class 'MakeLetName'
63 class MakeLetName letName where
64 makeLetName :: SharingName -> IO letName
65
66 -- ** Type 'ShowLetName'
67 -- | Useful on golden unit tests because 'StableName'
68 -- change often when changing unrelated source code
69 -- or even changing basic GHC or executable flags.
70 class ShowLetName (showName::Bool) letName where
71 showLetName :: letName -> String
72 -- | Like 'Show'.
73 instance Show letName => ShowLetName 'True letName where
74 showLetName = show
75 -- | Always return @"<hidden>"@,
76 instance ShowLetName 'False letName where
77 showLetName _p = "<hidden>"
78
79 -- * Type 'SharingName'
80 -- | Note that the observable sharing enabled by 'StableName'
81 -- is not perfect as it will not observe all the sharing explicitely done.
82 --
83 -- Note also that the observed sharing could be different between ghc and ghci.
84 data SharingName = forall a. SharingName (StableName a)
85 -- | @('makeSharingName' x)@ is like @('makeStableName' x)@ but it also forces
86 -- evaluation of @(x)@ to ensure that the 'StableName' is correct first time,
87 -- which avoids to produce a tree bigger than needed.
88 --
89 -- Note that this function uses 'unsafePerformIO' instead of returning in 'IO',
90 -- this is apparently required to avoid infinite loops due to unstable 'StableName'
91 -- in compiled code, and sometimes also in ghci.
92 --
93 -- Note that maybe [pseq should be used here](https://gitlab.haskell.org/ghc/ghc/-/issues/2916).
94 makeSharingName :: a -> SharingName
95 makeSharingName !x = SharingName $ unsafePerformIO $ makeStableName x
96
97 instance Eq SharingName where
98 SharingName x == SharingName y = eqStableName x y
99 instance Hashable SharingName where
100 hash (SharingName n) = hashStableName n
101 hashWithSalt salt (SharingName n) = hashWithSalt salt n
102 {-
103 instance Show SharingName where
104 showsPrec _ (SharingName n) = showHex (I# (unsafeCoerce# n))
105 -}
106
107 -- * Type 'ObserveSharing'
108 newtype ObserveSharing letName repr a = ObserveSharing { unObserveSharing ::
109 MT.ReaderT (HashSet SharingName)
110 (MT.State (ObserveSharingState letName))
111 (FinalizeSharing letName repr a) }
112
113 -- | Interpreter detecting some (Haskell embedded) @let@ definitions used at
114 -- least once and/or recursively, in order to replace them
115 -- with the 'def' and 'ref' combinators.
116 -- See [Type-safe observable sharing in Haskell](https://doi.org/10.1145/1596638.1596653)
117 --
118 -- Beware not to apply 'observeSharing' more than once on the same term
119 -- otherwise some 'shareable' introduced by the first call
120 -- would be removed by the second call.
121 observeSharing ::
122 Eq letName =>
123 Hashable letName =>
124 Show letName =>
125 ObserveSharing letName repr a ->
126 WithSharing letName repr a
127 observeSharing (ObserveSharing m) =
128 let (fs, st) = MT.runReaderT m mempty `MT.runState`
129 ObserveSharingState
130 { oss_refs = HM.empty
131 , oss_recs = HS.empty
132 } in
133 let refs = HS.fromList $
134 (`foldMap` oss_refs st) $ (\(letName, refCount) ->
135 if refCount > 0 then [letName] else []) in
136 --trace (show refs) $
137 MT.runWriter $
138 (`MT.runReaderT` refs) $
139 unFinalizeSharing fs
140
141 -- ** Type 'SomeLet'
142 data SomeLet repr = forall a. SomeLet (repr a)
143
144 -- ** Type 'WithSharing'
145 type WithSharing letName repr a =
146 (repr a, HM.HashMap letName (SomeLet repr))
147 {-
148 -- * Type 'WithSharing'
149 data WithSharing letName repr a = WithSharing
150 { lets :: HM.HashMap letName (SomeLet repr)
151 , body :: repr a
152 }
153 mapWithSharing ::
154 (forall v. repr v -> repr v) ->
155 WithSharing letName repr a ->
156 WithSharing letName repr a
157 mapWithSharing f ws = WithSharing
158 { lets = (\(SomeLet repr) -> SomeLet (f repr)) <$> lets ws
159 , body = f (body ws)
160 }
161 -}
162
163 -- ** Type 'ObserveSharingState'
164 data ObserveSharingState letName = ObserveSharingState
165 { oss_refs :: HashMap SharingName (letName, Int)
166 , oss_recs :: HashSet SharingName
167 -- ^ TODO: unused so far, will it be useful somewhere at a later stage?
168 }
169
170 observeSharingNode ::
171 Eq letName =>
172 Hashable letName =>
173 Show letName =>
174 Letable letName repr =>
175 MakeLetName letName =>
176 ObserveSharing letName repr a ->
177 ObserveSharing letName repr a
178 observeSharingNode (ObserveSharing m) = ObserveSharing $ do
179 let nodeName = makeSharingName m
180 st <- MT.lift MT.get
181 ((letName, before), preds) <- getCompose $ HM.alterF (\before ->
182 Compose $ case before of
183 Nothing -> do
184 let letName = unsafePerformIO $ makeLetName nodeName
185 return ((letName, before), Just (letName, 0))
186 Just (letName, refCount) -> do
187 return ((letName, before), Just (letName, refCount + 1))
188 ) nodeName (oss_refs st)
189 parentNames <- MT.ask
190 if nodeName `HS.member` parentNames
191 then do
192 MT.lift $ MT.put st
193 { oss_refs = preds
194 , oss_recs = HS.insert nodeName (oss_recs st)
195 }
196 return $ ref True letName
197 else do
198 MT.lift $ MT.put st{ oss_refs = preds }
199 if isNothing before
200 then MT.local (HS.insert nodeName) (shareable letName <$> m)
201 else return $ ref False letName
202
203 type instance Output (ObserveSharing letName repr) = FinalizeSharing letName repr
204 instance
205 ( Letable letName repr
206 , MakeLetName letName
207 , Eq letName
208 , Hashable letName
209 , Show letName
210 ) => Trans (FinalizeSharing letName repr) (ObserveSharing letName repr) where
211 trans = observeSharingNode . ObserveSharing . return
212 instance
213 ( Letable letName repr
214 , MakeLetName letName
215 , Eq letName
216 , Hashable letName
217 , Show letName
218 ) => Trans1 (FinalizeSharing letName repr) (ObserveSharing letName repr) where
219 trans1 f x = observeSharingNode $ ObserveSharing $
220 f <$> unObserveSharing x
221 instance
222 ( Letable letName repr
223 , MakeLetName letName
224 , Eq letName
225 , Hashable letName
226 , Show letName
227 ) => Trans2 (FinalizeSharing letName repr) (ObserveSharing letName repr) where
228 trans2 f x y = observeSharingNode $ ObserveSharing $
229 f <$> unObserveSharing x
230 <*> unObserveSharing y
231 instance
232 ( Letable letName repr
233 , MakeLetName letName
234 , Eq letName
235 , Hashable letName
236 , Show letName
237 ) => Trans3 (FinalizeSharing letName repr) (ObserveSharing letName repr) where
238 trans3 f x y z = observeSharingNode $ ObserveSharing $
239 f <$> unObserveSharing x
240 <*> unObserveSharing y
241 <*> unObserveSharing z
242 instance Letable letName (ObserveSharing letName repr) where
243 shareable = error "[BUG]: observeSharing MUST NOT be applied twice"
244 ref = error "[BUG]: observeSharing MUST NOT be applied twice"
245 instance Letsable letName (ObserveSharing letName repr) where
246 lets = error "[BUG]: observeSharing MUST NOT be applied twice"
247
248 -- * Type 'FinalizeSharing'
249 -- | Remove 'shareable' when non-recursive or unused
250 -- or replace it by 'ref', moving 'def' a top.
251 newtype FinalizeSharing letName repr a = FinalizeSharing { unFinalizeSharing ::
252 MT.ReaderT (HS.HashSet letName)
253 (MT.Writer (LetBindings letName repr))
254 (repr a) }
255
256 -- ** Type 'LetBindings'
257 type LetBindings letName repr = HM.HashMap letName (SomeLet repr)
258
259 type instance Output (FinalizeSharing _letName repr) = repr
260 instance
261 ( Eq letName
262 , Hashable letName
263 ) => Trans repr (FinalizeSharing letName repr) where
264 trans = FinalizeSharing . pure
265 instance
266 ( Eq letName
267 , Hashable letName
268 ) => Trans1 repr (FinalizeSharing letName repr) where
269 trans1 f x = FinalizeSharing $ f <$> unFinalizeSharing x
270 instance
271 ( Eq letName
272 , Hashable letName
273 ) => Trans2 repr (FinalizeSharing letName repr) where
274 trans2 f x y = FinalizeSharing $
275 f <$> unFinalizeSharing x
276 <*> unFinalizeSharing y
277 instance
278 ( Eq letName
279 , Hashable letName
280 ) => Trans3 repr (FinalizeSharing letName repr) where
281 trans3 f x y z = FinalizeSharing $
282 f <$> unFinalizeSharing x
283 <*> unFinalizeSharing y
284 <*> unFinalizeSharing z
285 instance
286 ( Letable letName repr
287 , Eq letName
288 , Hashable letName
289 , Show letName
290 ) => Letable letName (FinalizeSharing letName repr) where
291 shareable name x = FinalizeSharing $ do
292 refs <- MT.ask
293 if name `HS.member` refs
294 -- This 'shareable' is 'ref'erenced, move it into the result,
295 -- to put it in scope even when some 'ref' to it exists outside of 'x'
296 -- (which can happen when a sub-expression is shared),
297 -- and replace it by a 'ref'.
298 then do
299 let (repr, defs) = MT.runWriter $ MT.runReaderT (unFinalizeSharing x) refs
300 MT.lift $ MT.tell $ HM.insert name (SomeLet repr) defs
301 return $ ref False name
302 -- Remove 'shareable'.
303 else
304 unFinalizeSharing x
305
306 -- * Class 'Letsable'
307 class Letsable letName repr where
308 -- | @('lets' defs x)@ let-binds @(defs)@ in @(x)@.
309 lets :: LetBindings letName repr -> repr a -> repr a
310 default lets ::
311 Trans repr (Output repr) =>
312 Liftable1 repr => Letsable letName (Output repr) =>
313 LetBindings letName repr -> repr a -> repr a
314 lets defs = lift1 (lets ((\(SomeLet val) -> SomeLet (trans val)) <$> defs))
315 {-
316 -- | Not used but can be written nonetheless.
317 instance
318 ( Letsable letName repr
319 , Eq letName
320 , Hashable letName
321 , Show letName
322 ) => Letsable letName (FinalizeSharing letName repr) where
323 lets defs x = FinalizeSharing $ do
324 ds <- traverse (\(SomeLet v) -> do
325 r <- unFinalizeSharing v
326 return (SomeLet r)
327 ) defs
328 MT.lift $ MT.tell ds
329 unFinalizeSharing x
330 -}