]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Univariant/Letable.hs
doc: update ToDo
[haskell/symantic-parser.git] / src / Symantic / Univariant / Letable.hs
1 {-# LANGUAGE AllowAmbiguousTypes #-} -- For ShowLetName
2 {-# LANGUAGE DefaultSignatures #-}
3 {-# LANGUAGE ExistentialQuantification #-} -- For SharingName
4 -- {-# LANGUAGE MagicHash #-} -- For unsafeCoerce#
5 module Symantic.Univariant.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 ((+))
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 Data.HashMap.Strict as HM
35 import qualified Data.HashSet as HS
36
37 import Symantic.Univariant.Trans
38
39 -- import Debug.Trace (trace)
40
41 -- * Class 'Letable'
42 -- | This class is not for end-users like usual symantic operators,
43 -- here 'def' and 'ref' are introduced by 'observeSharing'.
44 class Letable letName repr where
45 -- | @('def' letName x)@ let-binds @(letName)@ to be equal to @(x)@.
46 def :: letName -> repr a -> repr a
47 -- | @('ref' isRec letName)@ is a reference to @(letName)@.
48 -- @(isRec)@ is 'True' iif. this 'ref'erence is recursive,
49 -- ie. is reachable within its 'def'inition.
50 ref :: Bool -> letName -> repr a
51 default def ::
52 Liftable1 repr => Letable letName (Output repr) =>
53 letName -> repr a -> repr a
54 default ref ::
55 Liftable repr => Letable letName (Output repr) =>
56 Bool -> letName -> repr a
57 def n = lift1 (def n)
58 ref r n = lift (ref r n)
59
60 -- * Class 'MakeLetName'
61 class MakeLetName letName where
62 makeLetName :: SharingName -> IO letName
63
64 -- ** Type 'ShowLetName'
65 -- | Useful on golden unit tests because 'StableName'
66 -- change often when changing unrelated source code
67 -- or even changing basic GHC or executable flags.
68 class ShowLetName (showName::Bool) letName where
69 showLetName :: letName -> String
70 -- | Like 'Show'.
71 instance Show letName => ShowLetName 'True letName where
72 showLetName = show
73 -- | Always return @"<hidden>"@,
74 instance ShowLetName 'False letName where
75 showLetName _p = "<hidden>"
76
77 -- * Type 'SharingName'
78 -- | Note that the observable sharing enabled by 'StableName'
79 -- is not perfect as it will not observe all the sharing explicitely done.
80 --
81 -- Note also that the observed sharing could be different between ghc and ghci.
82 data SharingName = forall a. SharingName (StableName a)
83 -- | @('makeSharingName' x)@ is like @('makeStableName' x)@ but it also forces
84 -- evaluation of @(x)@ to ensure that the 'StableName' is correct first time,
85 -- which avoids to produce a tree bigger than needed.
86 --
87 -- Note that this function uses 'unsafePerformIO' instead of returning in 'IO',
88 -- this is apparently required to avoid infinite loops due to unstable 'StableName'
89 -- in compiled code, and sometimes also in ghci.
90 --
91 -- Note that maybe [pseq should be used here](https://gitlab.haskell.org/ghc/ghc/-/issues/2916).
92 makeSharingName :: a -> SharingName
93 makeSharingName !x = SharingName $ unsafePerformIO $ makeStableName x
94
95 instance Eq SharingName where
96 SharingName x == SharingName y = eqStableName x y
97 instance Hashable SharingName where
98 hash (SharingName n) = hashStableName n
99 hashWithSalt salt (SharingName n) = hashWithSalt salt n
100 {-
101 instance Show SharingName where
102 showsPrec _ (SharingName n) = showHex (I# (unsafeCoerce# n))
103 -}
104
105 -- * Type 'ObserveSharing'
106 -- | Interpreter detecting some (Haskell embedded) @let@ definitions used at
107 -- least once and/or recursively, in order to replace them
108 -- with the 'def' and 'ref' combinators.
109 -- See [Type-safe observable sharing in Haskell](https://doi.org/10.1145/1596638.1596653)
110 newtype ObserveSharing letName repr a = ObserveSharing { unObserveSharing ::
111 MT.ReaderT (HashSet SharingName)
112 (MT.State (ObserveSharingState letName))
113 (CleanDefs letName repr a) }
114
115 observeSharing ::
116 Eq letName =>
117 Hashable letName =>
118 ObserveSharing letName repr a ->
119 repr a
120 observeSharing (ObserveSharing m) = do
121 let (a, st) = MT.runReaderT m mempty `MT.runState`
122 ObserveSharingState
123 { oss_refs = HM.empty
124 , oss_recs = HS.empty
125 }
126 let refs = HS.fromList $
127 (`foldMap` oss_refs st) $ (\(letName, refCount) ->
128 if refCount > 0 then [letName] else [])
129 -- trace (show refs) $
130 unCleanDefs a refs
131
132 -- ** Type 'ObserveSharingState'
133 data ObserveSharingState letName = ObserveSharingState
134 { oss_refs :: HashMap SharingName (letName, Int)
135 , oss_recs :: HashSet SharingName
136 -- ^ TODO: unused so far, will it be useful somewhere at a later stage?
137 }
138
139 observeSharingNode ::
140 Eq letName =>
141 Hashable letName =>
142 Letable letName repr =>
143 MakeLetName letName =>
144 ObserveSharing letName repr a ->
145 ObserveSharing letName repr a
146 observeSharingNode (ObserveSharing m) = ObserveSharing $ do
147 let nodeName = makeSharingName m
148 st <- MT.lift MT.get
149 ((letName, before), preds) <- getCompose $ HM.alterF (\before ->
150 Compose $ case before of
151 Nothing -> do
152 let letName = unsafePerformIO $ makeLetName nodeName
153 return ((letName, before), Just (letName, 0))
154 Just (letName, refCount) -> do
155 return ((letName, before), Just (letName, refCount + 1))
156 ) nodeName (oss_refs st)
157 parentNames <- MT.ask
158 if nodeName `HS.member` parentNames
159 then do
160 MT.lift $ MT.put st
161 { oss_refs = preds
162 , oss_recs = HS.insert nodeName (oss_recs st)
163 }
164 return $ ref True letName
165 else do
166 MT.lift $ MT.put st{ oss_refs = preds }
167 if isNothing before
168 then MT.local (HS.insert nodeName) (def letName <$> m)
169 else return $ ref False letName
170
171 type instance Output (ObserveSharing letName repr) = CleanDefs letName repr
172 instance
173 ( Letable letName repr
174 , MakeLetName letName
175 , Eq letName
176 , Hashable letName
177 ) => Trans (CleanDefs letName repr) (ObserveSharing letName repr) where
178 trans = observeSharingNode . ObserveSharing . return
179 instance
180 ( Letable letName repr
181 , MakeLetName letName
182 , Eq letName
183 , Hashable letName
184 ) => Trans1 (CleanDefs letName repr) (ObserveSharing letName repr) where
185 trans1 f x = observeSharingNode $ ObserveSharing $
186 f <$> unObserveSharing x
187 instance
188 ( Letable letName repr
189 , MakeLetName letName
190 , Eq letName
191 , Hashable letName
192 ) => Trans2 (CleanDefs letName repr) (ObserveSharing letName repr) where
193 trans2 f x y = observeSharingNode $ ObserveSharing $
194 f <$> unObserveSharing x
195 <*> unObserveSharing y
196 instance
197 ( Letable letName repr
198 , MakeLetName letName
199 , Eq letName
200 , Hashable letName
201 ) => Trans3 (CleanDefs letName repr) (ObserveSharing letName repr) where
202 trans3 f x y z = observeSharingNode $ ObserveSharing $
203 f <$> unObserveSharing x
204 <*> unObserveSharing y
205 <*> unObserveSharing z
206 instance
207 ( Letable letName repr
208 , MakeLetName letName
209 , Eq letName
210 , Hashable letName
211 ) => Letable letName (ObserveSharing letName repr)
212
213 -- * Type 'CleanDefs'
214 -- | Remove 'def' when non-recursive or unused.
215 newtype CleanDefs letName repr a = CleanDefs { unCleanDefs ::
216 HS.HashSet letName -> repr a }
217
218 type instance Output (CleanDefs _letName repr) = repr
219 instance Trans repr (CleanDefs letName repr) where
220 trans = CleanDefs . pure
221 instance Trans1 repr (CleanDefs letName repr) where
222 trans1 f x = CleanDefs $ f <$> unCleanDefs x
223 instance Trans2 repr (CleanDefs letName repr) where
224 trans2 f x y = CleanDefs $
225 f <$> unCleanDefs x
226 <*> unCleanDefs y
227 instance Trans3 repr (CleanDefs letName repr) where
228 trans3 f x y z = CleanDefs $
229 f <$> unCleanDefs x
230 <*> unCleanDefs y
231 <*> unCleanDefs z
232 instance
233 ( Letable letName repr
234 , Eq letName
235 , Hashable letName
236 ) => Letable letName (CleanDefs letName repr) where
237 def name x = CleanDefs $ \refs ->
238 if name `HS.member` refs
239 then -- Perserve 'def'
240 def name $ unCleanDefs x refs
241 else -- Remove 'def'
242 unCleanDefs x refs