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