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.Liftable
  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     Liftable repr => Letable letName (Unlift repr) =>
  45     letName -> repr a -> repr a
  46   default ref ::
  47     Liftable repr => Letable letName (Unlift 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 Unlift (ObserveSharing letName repr) = CleanDefs letName repr
 135 instance
 136   ( Letable letName repr
 137   , MakeLetName letName
 138   , Eq letName
 139   , Hashable letName
 140   ) => Liftable (ObserveSharing letName repr) where
 141   lift x = observeSharingNode (ObserveSharing (return x))
 142   lift1 f x = observeSharingNode (ObserveSharing (f <$> unObserveSharing x))
 143   lift2 f x y = observeSharingNode $ ObserveSharing $
 144     f <$> unObserveSharing x
 145       <*> unObserveSharing y
 146   lift3 f x y z = observeSharingNode $ ObserveSharing $
 147     f <$> unObserveSharing x
 148       <*> unObserveSharing y
 149       <*> unObserveSharing z
 150
 151 -- * Type 'CleanDefs'
 152 -- | Remove 'def' when non-recursive or unused.
 153 newtype CleanDefs letName repr a = CleanDefs { unCleanDefs ::
 154   HS.HashSet letName -> repr a }
 155
 156 type instance Unlift (CleanDefs letName repr) = repr
 157 instance Liftable (CleanDefs letName repr) where
 158   lift = CleanDefs . pure
 159   lift1 f x = CleanDefs $
 160     f <$> unCleanDefs x
 161   lift2 f x y = CleanDefs $
 162     f <$> unCleanDefs x
 163       <*> unCleanDefs y
 164   lift3 f x y z = CleanDefs $
 165     f <$> unCleanDefs x
 166       <*> unCleanDefs y
 167       <*> unCleanDefs z
 168 instance
 169   ( Letable letName repr
 170   , Eq letName
 171   , Hashable letName
 172   ) => Letable letName (CleanDefs letName repr) where
 173   def name x = CleanDefs $ \refs ->
 174     if name `HS.member` refs
 175     then -- Perserve 'def'
 176       def name $ unCleanDefs x refs
 177     else -- Remove 'def'
 178       unCleanDefs x refs