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