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