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 ((+), 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 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 newtype ObserveSharing letName repr a = ObserveSharing { unObserveSharing ::
 107   MT.ReaderT (HashSet SharingName)
 108              (MT.State (ObserveSharingState letName))
 109              (CleanDefs letName repr a) }
 110
 111 -- | Interpreter detecting some (Haskell embedded) @let@ definitions used at
 112 -- least once and/or recursively, in order to replace them
 113 -- with the 'def' and 'ref' combinators.
 114 -- See [Type-safe observable sharing in Haskell](https://doi.org/10.1145/1596638.1596653)
 115 --
 116 -- Beware not to apply 'observeSharing' more than once on the same term
 117 -- otherwise some 'def' introduced by the first call would be removed by the second call.
 118 observeSharing ::
 119   Eq letName =>
 120   Hashable letName =>
 121   Show letName =>
 122   ObserveSharing letName repr a ->
 123   repr a
 124 observeSharing (ObserveSharing m) = do
 125   let (a, st) = MT.runReaderT m mempty `MT.runState`
 126         ObserveSharingState
 127           { oss_refs = HM.empty
 128           , oss_recs = HS.empty
 129           }
 130   let refs = HS.fromList $
 131         (`foldMap` oss_refs st) $ (\(letName, refCount) ->
 132           if refCount > 0 then [letName] else [])
 133   --trace (show refs) $
 134   unCleanDefs a refs
 135
 136 -- ** Type 'ObserveSharingState'
 137 data ObserveSharingState letName = ObserveSharingState
 138   { oss_refs :: HashMap SharingName (letName, Int)
 139   , oss_recs :: HashSet SharingName
 140     -- ^ TODO: unused so far, will it be useful somewhere at a later stage?
 141   }
 142
 143 observeSharingNode ::
 144   Eq letName =>
 145   Hashable letName =>
 146   Show letName =>
 147   Letable letName repr =>
 148   MakeLetName letName =>
 149   ObserveSharing letName repr a ->
 150   ObserveSharing letName repr a
 151 observeSharingNode (ObserveSharing m) = ObserveSharing $ do
 152   let nodeName = makeSharingName m
 153   st <- MT.lift MT.get
 154   ((letName, before), preds) <- getCompose $ HM.alterF (\before ->
 155     Compose $ case before of
 156       Nothing -> do
 157         let letName = unsafePerformIO $ makeLetName nodeName
 158         return ((letName, before), Just (letName, 0))
 159       Just (letName, refCount) -> do
 160         return ((letName, before), Just (letName, refCount + 1))
 161     ) nodeName (oss_refs st)
 162   parentNames <- MT.ask
 163   if nodeName `HS.member` parentNames
 164   then do
 165     MT.lift $ MT.put st
 166       { oss_refs = preds
 167       , oss_recs = HS.insert nodeName (oss_recs st)
 168       }
 169     return $ ref True letName
 170   else do
 171     MT.lift $ MT.put st{ oss_refs = preds }
 172     if isNothing before
 173       then MT.local (HS.insert nodeName) (def letName <$> m)
 174       else return $ ref False letName
 175
 176 type instance Output (ObserveSharing letName repr) = CleanDefs letName repr
 177 instance
 178   ( Letable letName repr
 179   , MakeLetName letName
 180   , Eq letName
 181   , Hashable letName
 182   , Show letName
 183   ) => Trans (CleanDefs letName repr) (ObserveSharing letName repr) where
 184   trans = observeSharingNode . ObserveSharing . return
 185 instance
 186   ( Letable letName repr
 187   , MakeLetName letName
 188   , Eq letName
 189   , Hashable letName
 190   , Show letName
 191   ) => Trans1 (CleanDefs letName repr) (ObserveSharing letName repr) where
 192   trans1 f x = observeSharingNode $ ObserveSharing $
 193     f <$> unObserveSharing x
 194 instance
 195   ( Letable letName repr
 196   , MakeLetName letName
 197   , Eq letName
 198   , Hashable letName
 199   , Show letName
 200   ) => Trans2 (CleanDefs letName repr) (ObserveSharing letName repr) where
 201   trans2 f x y = observeSharingNode $ ObserveSharing $
 202     f <$> unObserveSharing x
 203       <*> unObserveSharing y
 204 instance
 205   ( Letable letName repr
 206   , MakeLetName letName
 207   , Eq letName
 208   , Hashable letName
 209   , Show letName
 210   ) => Trans3 (CleanDefs letName repr) (ObserveSharing letName repr) where
 211   trans3 f x y z = observeSharingNode $ ObserveSharing $
 212     f <$> unObserveSharing x
 213       <*> unObserveSharing y
 214       <*> unObserveSharing z
 215 instance
 216   ( Letable letName repr
 217   , MakeLetName letName
 218   , Eq letName
 219   , Hashable letName
 220   , Show letName
 221   ) => Letable letName (ObserveSharing letName repr) where
 222   def = error "[BUG]: observeSharing MUST NOT be applied twice"
 223   ref = error "[BUG]: observeSharing MUST NOT be applied twice"
 224
 225 -- * Type 'CleanDefs'
 226 -- | Remove 'def' when non-recursive or unused.
 227 newtype CleanDefs letName repr a = CleanDefs { unCleanDefs ::
 228   HS.HashSet letName -> repr a }
 229
 230 type instance Output (CleanDefs _letName repr) = repr
 231 instance Trans repr (CleanDefs letName repr) where
 232   trans = CleanDefs . pure
 233 instance Trans1 repr (CleanDefs letName repr) where
 234   trans1 f x = CleanDefs $ f <$> unCleanDefs x
 235 instance Trans2 repr (CleanDefs letName repr) where
 236   trans2 f x y = CleanDefs $
 237     f <$> unCleanDefs x
 238       <*> unCleanDefs y
 239 instance Trans3 repr (CleanDefs letName repr) where
 240   trans3 f x y z = CleanDefs $
 241     f <$> unCleanDefs x
 242       <*> unCleanDefs y
 243       <*> unCleanDefs z
 244 instance
 245   ( Letable letName repr
 246   , Eq letName
 247   , Hashable letName
 248   , Show letName
 249   ) => Letable letName (CleanDefs letName repr) where
 250   def name x = CleanDefs $ \refs ->
 251     if name `HS.member` refs
 252     then -- Perserve 'def'
 253       def name $ unCleanDefs x refs
 254     else -- Remove 'def'
 255       unCleanDefs x refs