src/Symantic/Parser/Grammar/ObserveSharing.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 {-# LANGUAGE ExistentialQuantification #-}
   3 {-# LANGUAGE MagicHash #-}
   4 {-# OPTIONS_GHC -fno-warn-orphans #-}
   5 module Symantic.Parser.Grammar.ObserveSharing where
   6
   7 import Control.Applicative (Applicative(..))
   8 import Control.Monad (Monad(..), mapM)
   9 import Data.Bool (Bool(..))
  10 import Data.Eq (Eq(..))
  11 import Data.Function (($), (.))
  12 import Data.Functor (Functor(..), (<$>))
  13 import Data.Functor.Compose (Compose(..))
  14 import Data.HashMap.Strict (HashMap)
  15 import Data.HashSet (HashSet)
  16 import Data.Hashable (Hashable, hashWithSalt, hash)
  17 import Data.Maybe (Maybe(..), isNothing)
  18 import Data.Monoid (Monoid(..))
  19 import Data.Ord (Ord(..))
  20 import Debug.Trace (trace)
  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 Text.Show (Show(..))
  28 import qualified Control.Monad.Trans.Class as MT
  29 import qualified Control.Monad.Trans.Reader as MT
  30 import qualified Control.Monad.Trans.State as MT
  31 import qualified Data.List as List
  32 import qualified Language.Haskell.TH.Syntax as TH
  33
  34 import qualified Data.HashMap.Strict as HM
  35 import qualified Data.HashSet        as HS
  36
  37 import Symantic.Base.Univariant
  38 import qualified Symantic.Parser.Grammar.Combinators as P
  39
  40 -- * Type 'SharingName'
  41 data SharingName = forall a. SharingName (StableName a)
  42 -- Force evaluation of p to ensure that the StableName is correct first time, which avoid to produce a tree bigger than needed
  43 makeSharingName :: repr a -> IO SharingName
  44 makeSharingName !p = fmap SharingName (makeStableName p)
  45 instance Eq SharingName where
  46   SharingName n == SharingName m = eqStableName n m
  47 instance Hashable SharingName where
  48   hash (SharingName n) = hashStableName n
  49   hashWithSalt salt (SharingName n) = hashWithSalt salt n
  50 instance Show SharingName where
  51   showsPrec _ (SharingName n) = showHex (I# (unsafeCoerce# n))
  52
  53 -- * Type 'ObserveSharing'
  54 -- | Combinator interpreter detecting (Haskell embedded) @let@ definitions used at least twice or recursively, in order to replace them with the 'def' and 'ref' combinators.
  55 -- See [Type-safe observable sharing in Haskell](https://doi.org/10.1145/1596638.1596653)
  56 newtype ObserveSharing repr a = ObserveSharing { unObserveSharing :: MT.ReaderT (HashSet SharingName) (MT.StateT ObserveSharingState IO) (CleanDefs repr a) }
  57
  58 observeSharing :: ObserveSharing repr a -> IO (repr a)
  59 observeSharing (ObserveSharing m) = do
  60   (a, st) <- MT.runStateT (MT.runReaderT m mempty) emptyObserveSharingState
  61   let refs = HM.fromList $ List.filter (\(_n,c) -> c > 1) $ HM.elems $ defref_shared st
  62   return $
  63     trace (show refs) $
  64     unCleanDefs a refs
  65
  66 instance Hashable TH.Name where
  67   hashWithSalt s = hashWithSalt s . show
  68
  69 -- * Type 'CleanDefs'
  70 -- | Remove 'def' non-recursive or only used once.
  71 newtype CleanDefs repr a = CleanDefs { unCleanDefs :: HM.HashMap TH.Name Int -> repr a }
  72
  73 type instance Unlift (CleanDefs repr) = repr
  74 instance Liftable (CleanDefs repr) where
  75   lift = CleanDefs . pure
  76   lift1 f x = CleanDefs (f <$> unCleanDefs x)
  77   lift2 f x y = CleanDefs (f <$> unCleanDefs x <*> unCleanDefs y)
  78   lift3 f x y z = CleanDefs (f <$> unCleanDefs x <*> unCleanDefs y <*> unCleanDefs z)
  79 instance Letable repr => Letable (CleanDefs repr) where
  80   def name x = CleanDefs $ \refs ->
  81     case HM.lookup name refs of
  82       Just c | c > 1 -> def name $ unCleanDefs x refs
  83       _ -> unCleanDefs x refs
  84 instance P.Applicable repr => P.Applicable (CleanDefs repr)
  85 instance P.Alternable repr => P.Alternable (CleanDefs repr)
  86 instance P.Charable repr => P.Charable (CleanDefs repr)
  87 instance P.Selectable repr => P.Selectable (CleanDefs repr)
  88 instance P.Matchable repr => P.Matchable (CleanDefs repr) where
  89   conditional cs bs a b =
  90     CleanDefs (P.conditional cs <$> mapM unCleanDefs bs <*> unCleanDefs a <*> unCleanDefs b)
  91 instance P.Lookable repr => P.Lookable (CleanDefs repr)
  92 instance P.Foldable repr => P.Foldable (CleanDefs repr)
  93
  94 -- ** Type 'ObserveSharingState'
  95 data ObserveSharingState = ObserveSharingState
  96  { defref_shared :: HashMap SharingName (TH.Name, Int)
  97  , defref_recs :: HashSet SharingName
  98  } deriving (Show)
  99
 100 emptyObserveSharingState :: ObserveSharingState
 101 emptyObserveSharingState = ObserveSharingState
 102  { defref_shared = HM.empty
 103  , defref_recs = HS.empty
 104  }
 105
 106 -- ** Class 'Letable'
 107 class Letable repr where
 108   def :: Pointer -> repr a -> repr a
 109   ref :: Bool -> Pointer -> repr a
 110   default def ::
 111     Liftable repr => Letable (Unlift repr) =>
 112     Pointer -> repr a -> repr a
 113   default ref ::
 114     Liftable repr => Letable (Unlift repr) =>
 115     Bool -> Pointer -> repr a
 116   def n = lift1 (def n)
 117   ref r n = lift (ref r n)
 118
 119 -- *** Type 'Pointer'
 120 type Pointer = TH.Name
 121
 122 observeSharingNode :: Letable repr => ObserveSharing repr a -> ObserveSharing repr a
 123 observeSharingNode node@(ObserveSharing m) = ObserveSharing $ do
 124   pName <- MT.lift $ MT.lift $ makeSharingName node
 125   -- let pName = showHex (I# (unsafeCoerce# name)) ""
 126   -- let pName = SharingName name
 127   st <- MT.lift MT.get
 128   ((before, qName), preds) <- getCompose $ HM.alterF (\v ->
 129     Compose $ case v of
 130       Nothing -> do
 131         qName <- MT.lift $ MT.lift $ TH.qNewName ("let"{-<>show pName-})
 132         return ((v, qName), Just (qName, 1))
 133       Just (qName, c) -> do
 134         return ((v, qName), Just (qName, c + 1))
 135     ) pName (defref_shared st)
 136   seen <- MT.ask
 137   if HS.member pName seen
 138   then do
 139     MT.lift $ MT.put st
 140      { defref_shared = preds
 141      , defref_recs = HS.insert pName (defref_recs st)
 142      }
 143     return $ ref True qName
 144   else do
 145     MT.lift $ MT.put st{ defref_shared = preds }
 146     if isNothing before
 147      then MT.local (HS.insert pName) (def qName <$> m)
 148      else return $ ref False qName
 149
 150 type instance Unlift (ObserveSharing repr) = CleanDefs repr
 151 instance Letable repr => Liftable (ObserveSharing repr) where
 152   lift x = observeSharingNode (ObserveSharing (return x))
 153   lift1 f x = observeSharingNode (ObserveSharing (f <$> unObserveSharing x))
 154   lift2 f x y = observeSharingNode (ObserveSharing (f <$> unObserveSharing x <*> unObserveSharing y))
 155   lift3 f x y z = observeSharingNode (ObserveSharing (f <$> unObserveSharing x <*> unObserveSharing y <*> unObserveSharing z))
 156 instance (Letable repr, P.Charable repr) => P.Charable (ObserveSharing repr)
 157 instance (Letable repr, P.Alternable repr) => P.Alternable (ObserveSharing repr)
 158 instance (Letable repr, P.Applicable repr) => P.Applicable (ObserveSharing repr)
 159 instance (Letable repr, P.Selectable repr) => P.Selectable (ObserveSharing repr)
 160 instance (Letable repr, P.Matchable repr) => P.Matchable (ObserveSharing repr) where
 161   -- Here the default definition does not fit since there is no lift* for its type and thus handles 'bs' itself, which is not the transformation wanted.
 162   conditional cs bs a b =
 163     observeSharingNode (ObserveSharing (P.conditional cs <$> mapM unObserveSharing bs <*> unObserveSharing a <*> unObserveSharing b))
 164 instance (Letable repr, P.Foldable repr) => P.Foldable (ObserveSharing repr)
 165 instance (Letable repr, P.Lookable repr) => P.Lookable (ObserveSharing repr)