-{-# LANGUAGE AllowAmbiguousTypes #-} -- For ShowLetName
-{-# LANGUAGE BangPatterns #-} -- For makeSharingName
-{-# LANGUAGE DataKinds #-} -- For ShowLetName
-{-# LANGUAGE ExistentialQuantification #-} -- For SharingName
+-- For ShowLetName
+{-# LANGUAGE AllowAmbiguousTypes #-}
+-- For makeSharingName
+{-# LANGUAGE BangPatterns #-}
+-- For ShowLetName
+{-# LANGUAGE DataKinds #-}
+-- For SharingName
+{-# LANGUAGE ExistentialQuantification #-}
+
-- {-# LANGUAGE MagicHash #-} -- For unsafeCoerce#
-module Symantic.SharingObserver where
+module Symantic.Semantics.SharingObserver where
-import Control.Applicative (Applicative(..))
-import Control.Monad (Monad(..))
+import Control.Applicative (Applicative (..))
+import Control.Monad (Monad (..))
import Data.Bool
-import Data.Eq (Eq(..))
+import Data.Eq (Eq (..))
import Data.Function (($), (.))
import Data.Functor (Functor, (<$>))
-import Data.Functor.Compose (Compose(..))
+import Data.Functor.Compose (Compose (..))
import Data.HashMap.Strict (HashMap)
import Data.HashSet (HashSet)
-import Data.Hashable (Hashable, hashWithSalt, hash)
+import Data.Hashable (Hashable, hash, hashWithSalt)
import Data.Int (Int)
-import Data.Maybe (Maybe(..), isNothing)
-import Data.Monoid (Monoid(..))
-import Data.Ord (Ord(..))
+import Data.Maybe (Maybe (..), isNothing)
+import Data.Monoid (Monoid (..))
+import Data.Ord (Ord (..))
+
-- import GHC.Exts (Int(..))
-- import GHC.Prim (unsafeCoerce#)
-import GHC.StableName (StableName(..), makeStableName, hashStableName, eqStableName)
+import GHC.StableName (StableName (..), eqStableName, hashStableName, makeStableName)
+
-- import Numeric (showHex)
-import Prelude ((+), error)
+
+import Control.Monad.Trans.Class qualified as MT
+import Control.Monad.Trans.Reader qualified as MT
+import Control.Monad.Trans.State qualified as MT
+import Control.Monad.Trans.Writer qualified as MT
+import Data.HashMap.Strict qualified as HM
+import Data.HashSet qualified as HS
import System.IO (IO)
import System.IO.Unsafe (unsafePerformIO)
-import Text.Show (Show(..))
-import qualified Control.Monad.Trans.Class as MT
-import qualified Control.Monad.Trans.Reader as MT
-import qualified Control.Monad.Trans.State as MT
-import qualified Control.Monad.Trans.Writer as MT
-import qualified Data.HashMap.Strict as HM
-import qualified Data.HashSet as HS
+import Text.Show (Show (..))
+import Prelude (error, (+))
-import Symantic.Derive
+import Symantic.Syntaxes.Derive
-- * Class 'Referenceable'
+
-- | This class is not for end-users like usual symantic operators,
-- though it will have to be defined on end-users' interpreters.
-class Referenceable letName repr where
+class Referenceable letName sem where
-- | @('ref' isRec letName)@ is a reference to @(letName)@.
-- It is introduced by 'observeSharing'.
-- @(isRec)@ is 'True' iif. this 'ref'erence is recursive,
-- ie. appears within its 'define'.
--
-- TODO: index 'letName' with 'a' to enable dependent-map
- ref :: Bool -> letName -> repr a
+ ref :: Bool -> letName -> sem a
ref isRec name = liftDerived (ref isRec name)
default ref ::
- FromDerived (Referenceable letName) repr =>
- Bool -> letName -> repr a
+ FromDerived (Referenceable letName) sem =>
+ Bool ->
+ letName ->
+ sem a
-- * Class 'Definable'
+
-- | This class is not for end-users like usual symantic operators.
-- There should be not need to use it outside this module,
-- because used 'define's are gathered in 'Letsable'.
-class Definable letName repr where
+class Definable letName sem where
-- | @('define' letName sub)@ let-binds @(letName)@ to be equal to @(sub)@.
-- This is a temporary node either replaced
-- by 'ref' and an entry in 'lets''s 'LetBindings',
-- or removed when no 'ref'erence is made to it.
- define :: letName -> repr a -> repr a
+ define :: letName -> sem a -> sem a
define name = liftDerived1 (define name)
default define ::
- FromDerived1 (Definable letName) repr =>
- letName -> repr a -> repr a
+ FromDerived1 (Definable letName) sem =>
+ letName ->
+ sem a ->
+ sem a
-- * Class 'MakeLetName'
class MakeLetName letName where
makeLetName :: SharingName -> IO letName
-- * Type 'SharingName'
+
-- | Note that the observable sharing enabled by 'StableName'
-- is not perfect as it will not observe all the sharing explicitely done.
--
-- Note also that the observed sharing could be different between ghc and ghci.
data SharingName = forall a. SharingName (StableName a)
+
-- | @('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.
instance Hashable SharingName where
hash (SharingName n) = hashStableName n
hashWithSalt salt (SharingName n) = hashWithSalt salt n
+
{-
instance Show SharingName where
showsPrec _ (SharingName n) = showHex (I# (unsafeCoerce# n))
-}
-- * Type 'SharingObserver'
-newtype SharingObserver letName repr a = SharingObserver { unSharingObserver ::
- MT.ReaderT (HashSet SharingName)
- (MT.State (SharingObserverState letName))
- (SharingFinalizer letName repr a) }
+newtype SharingObserver letName sem a = SharingObserver
+ { unSharingObserver ::
+ MT.ReaderT
+ (HashSet SharingName)
+ (MT.State (SharingObserverState letName))
+ (SharingFinalizer letName sem a)
+ }
-- | Interpreter detecting some (Haskell embedded) @let@ definitions used at
-- least once and/or recursively, in order to replace them
Eq letName =>
Hashable letName =>
Show letName =>
- SharingObserver letName repr a ->
- WithSharing letName repr a
+ SharingObserver letName sem a ->
+ WithSharing letName sem a
observeSharing (SharingObserver m) =
- let (fs, st) = MT.runReaderT m mempty `MT.runState`
- SharingObserverState
- { oss_refs = HM.empty
- , oss_recs = HS.empty
- } in
- let refs = HS.fromList
- [ letName
- | (letName, refCount) <- HM.elems (oss_refs st)
- , refCount > 0
- ] in
- --trace (show refs) $
- MT.runWriter $
- (`MT.runReaderT` refs) $
- unFinalizeSharing fs
+ let (fs, st) =
+ MT.runReaderT m mempty
+ `MT.runState` SharingObserverState
+ { oss_refs = HM.empty
+ , oss_recs = HS.empty
+ }
+ in let refs =
+ HS.fromList
+ [ letName
+ | (letName, refCount) <- HM.elems (oss_refs st)
+ , refCount > 0
+ ]
+ in --trace (show refs) $
+ MT.runWriter $
+ (`MT.runReaderT` refs) $
+ unFinalizeSharing fs
-- ** Type 'WithSharing'
-type WithSharing letName repr a =
- (repr a, HM.HashMap letName (SomeLet repr))
+type WithSharing letName sem a =
+ (sem a, HM.HashMap letName (SomeLet sem))
+
{-
-- * Type 'WithSharing'
-data WithSharing letName repr a = WithSharing
- { lets :: HM.HashMap letName (SomeLet repr)
- , body :: repr a
+data WithSharing letName sem a = WithSharing
+ { lets :: HM.HashMap letName (SomeLet sem)
+ , body :: sem a
}
mapWithSharing ::
- (forall v. repr v -> repr v) ->
- WithSharing letName repr a ->
- WithSharing letName repr a
+ (forall v. sem v -> sem v) ->
+ WithSharing letName sem a ->
+ WithSharing letName sem a
mapWithSharing f ws = WithSharing
- { lets = (\(SomeLet repr) -> SomeLet (f repr)) <$> lets ws
+ { lets = (\(SomeLet sem) -> SomeLet (f sem)) <$> lets ws
, body = f (body ws)
}
-}
Eq letName =>
Hashable letName =>
Show letName =>
- Referenceable letName repr =>
+ Referenceable letName sem =>
MakeLetName letName =>
- SharingObserver letName repr a ->
- SharingObserver letName repr a
+ SharingObserver letName sem a ->
+ SharingObserver letName sem a
observeSharingNode (SharingObserver m) = SharingObserver $ do
let nodeName = makeSharingName m
st <- MT.lift MT.get
- ((letName, seenBefore), seen) <- getCompose $ HM.alterF (\seenBefore ->
- -- Compose is used to return (letName, seenBefore) along seen
- -- in the same HashMap lookup.
- Compose $ return $ case seenBefore of
- Nothing ->
- ((letName, seenBefore), Just (letName, 0))
- where letName = unsafePerformIO $ makeLetName nodeName
- Just (letName, refCount) ->
- ((letName, seenBefore), Just (letName, refCount + 1))
- ) nodeName (oss_refs st)
+ ((letName, seenBefore), seen) <-
+ getCompose $
+ HM.alterF
+ ( \seenBefore ->
+ -- Compose is used to return (letName, seenBefore) along seen
+ -- in the same HashMap lookup.
+ Compose $
+ return $ case seenBefore of
+ Nothing ->
+ ((letName, seenBefore), Just (letName, 0))
+ where
+ letName = unsafePerformIO $ makeLetName nodeName
+ Just (letName, refCount) ->
+ ((letName, seenBefore), Just (letName, refCount + 1))
+ )
+ nodeName
+ (oss_refs st)
parentNames <- MT.ask
if nodeName `HS.member` parentNames
- then do -- recursive reference to nodeName:
- -- update seen references
- -- and mark nodeName as recursive
- MT.lift $ MT.put st
- { oss_refs = seen
- , oss_recs = HS.insert nodeName (oss_recs st)
- }
- return $ ref True letName
- else do -- non-recursive reference to nodeName:
- -- update seen references
- -- and recurse if the nodeName hasn't been seen before
- -- (would be in a preceding sibling branch, not in parentNames).
- MT.lift $ MT.put st{ oss_refs = seen }
- if isNothing seenBefore
- then MT.local (HS.insert nodeName) (define letName <$> m)
- else return $ ref False letName
-
-type instance Derived (SharingObserver letName repr) = SharingFinalizer letName repr
+ then do
+ -- recursive reference to nodeName:
+ -- update seen references
+ -- and mark nodeName as recursive
+ MT.lift $
+ MT.put
+ st
+ { oss_refs = seen
+ , oss_recs = HS.insert nodeName (oss_recs st)
+ }
+ return $ ref True letName
+ else do
+ -- non-recursive reference to nodeName:
+ -- update seen references
+ -- and recurse if the nodeName hasn't been seen before
+ -- (would be in a preceding sibling branch, not in parentNames).
+ MT.lift $ MT.put st{oss_refs = seen}
+ if isNothing seenBefore
+ then MT.local (HS.insert nodeName) (define letName <$> m)
+ else return $ ref False letName
+
+type instance Derived (SharingObserver letName sem) = SharingFinalizer letName sem
instance
- ( Referenceable letName repr
+ ( Referenceable letName sem
, MakeLetName letName
, Eq letName
, Hashable letName
, Show letName
- ) => LiftDerived (SharingObserver letName repr) where
+ ) =>
+ LiftDerived (SharingObserver letName sem)
+ where
liftDerived = observeSharingNode . SharingObserver . return
instance
- ( Referenceable letName repr
+ ( Referenceable letName sem
, MakeLetName letName
, Eq letName
, Hashable letName
, Show letName
- ) => LiftDerived1 (SharingObserver letName repr) where
- liftDerived1 f a = observeSharingNode $ SharingObserver $
- f <$> unSharingObserver a
+ ) =>
+ LiftDerived1 (SharingObserver letName sem)
+ where
+ liftDerived1 f a =
+ observeSharingNode $
+ SharingObserver $
+ f <$> unSharingObserver a
instance
- ( Referenceable letName repr
+ ( Referenceable letName sem
, MakeLetName letName
, Eq letName
, Hashable letName
, Show letName
- ) => LiftDerived2 (SharingObserver letName repr) where
- liftDerived2 f a b = observeSharingNode $ SharingObserver $
- f <$> unSharingObserver a
- <*> unSharingObserver b
+ ) =>
+ LiftDerived2 (SharingObserver letName sem)
+ where
+ liftDerived2 f a b =
+ observeSharingNode $
+ SharingObserver $
+ f <$> unSharingObserver a
+ <*> unSharingObserver b
instance
- ( Referenceable letName repr
+ ( Referenceable letName sem
, MakeLetName letName
, Eq letName
, Hashable letName
, Show letName
- ) => LiftDerived3 (SharingObserver letName repr) where
- liftDerived3 f a b c = observeSharingNode $ SharingObserver $
- f <$> unSharingObserver a
- <*> unSharingObserver b
- <*> unSharingObserver c
+ ) =>
+ LiftDerived3 (SharingObserver letName sem)
+ where
+ liftDerived3 f a b c =
+ observeSharingNode $
+ SharingObserver $
+ f <$> unSharingObserver a
+ <*> unSharingObserver b
+ <*> unSharingObserver c
instance
- ( Referenceable letName repr
+ ( Referenceable letName sem
, MakeLetName letName
, Eq letName
, Hashable letName
, Show letName
- ) => LiftDerived4 (SharingObserver letName repr) where
- liftDerived4 f a b c d = observeSharingNode $ SharingObserver $
- f <$> unSharingObserver a
- <*> unSharingObserver b
- <*> unSharingObserver c
- <*> unSharingObserver d
-instance Referenceable letName (SharingObserver letName repr) where
+ ) =>
+ LiftDerived4 (SharingObserver letName sem)
+ where
+ liftDerived4 f a b c d =
+ observeSharingNode $
+ SharingObserver $
+ f <$> unSharingObserver a
+ <*> unSharingObserver b
+ <*> unSharingObserver c
+ <*> unSharingObserver d
+instance Referenceable letName (SharingObserver letName sem) where
ref = error "[BUG]: observeSharing MUST NOT be applied twice"
-instance Definable letName (SharingObserver letName repr) where
+instance Definable letName (SharingObserver letName sem) where
define = error "[BUG]: observeSharing MUST NOT be applied twice"
-instance Letsable letName (SharingObserver letName repr) where
+instance Letsable letName (SharingObserver letName sem) where
lets = error "[BUG]: observeSharing MUST NOT be applied twice"
-- * Type 'SharingFinalizer'
+
-- | Remove 'define' when non-recursive or unused
-- or replace it by 'ref', moving 'define's to the top.
-newtype SharingFinalizer letName repr a = SharingFinalizer { unFinalizeSharing ::
- MT.ReaderT (HS.HashSet letName)
- (MT.Writer (LetBindings letName repr))
- (repr a) }
-
-type instance Derived (SharingFinalizer _letName repr) = repr
-instance (Eq letName, Hashable letName) =>
- LiftDerived (SharingFinalizer letName repr) where
+newtype SharingFinalizer letName sem a = SharingFinalizer
+ { unFinalizeSharing ::
+ MT.ReaderT
+ (HS.HashSet letName)
+ (MT.Writer (LetBindings letName sem))
+ (sem a)
+ }
+
+type instance Derived (SharingFinalizer _letName sem) = sem
+instance
+ (Eq letName, Hashable letName) =>
+ LiftDerived (SharingFinalizer letName sem)
+ where
liftDerived = SharingFinalizer . pure
-instance (Eq letName, Hashable letName) =>
- LiftDerived1 (SharingFinalizer letName repr) where
+instance
+ (Eq letName, Hashable letName) =>
+ LiftDerived1 (SharingFinalizer letName sem)
+ where
liftDerived1 f a = SharingFinalizer $ f <$> unFinalizeSharing a
-instance (Eq letName, Hashable letName) =>
- LiftDerived2 (SharingFinalizer letName repr) where
- liftDerived2 f a b = SharingFinalizer $
- f <$> unFinalizeSharing a
- <*> unFinalizeSharing b
-instance (Eq letName, Hashable letName) =>
- LiftDerived3 (SharingFinalizer letName repr) where
- liftDerived3 f a b c = SharingFinalizer $
- f <$> unFinalizeSharing a
- <*> unFinalizeSharing b
- <*> unFinalizeSharing c
-instance (Eq letName, Hashable letName) =>
- LiftDerived4 (SharingFinalizer letName repr) where
- liftDerived4 f a b c d = SharingFinalizer $
- f <$> unFinalizeSharing a
- <*> unFinalizeSharing b
- <*> unFinalizeSharing c
- <*> unFinalizeSharing d
instance
- ( Referenceable letName repr
+ (Eq letName, Hashable letName) =>
+ LiftDerived2 (SharingFinalizer letName sem)
+ where
+ liftDerived2 f a b =
+ SharingFinalizer $
+ f <$> unFinalizeSharing a
+ <*> unFinalizeSharing b
+instance
+ (Eq letName, Hashable letName) =>
+ LiftDerived3 (SharingFinalizer letName sem)
+ where
+ liftDerived3 f a b c =
+ SharingFinalizer $
+ f <$> unFinalizeSharing a
+ <*> unFinalizeSharing b
+ <*> unFinalizeSharing c
+instance
+ (Eq letName, Hashable letName) =>
+ LiftDerived4 (SharingFinalizer letName sem)
+ where
+ liftDerived4 f a b c d =
+ SharingFinalizer $
+ f <$> unFinalizeSharing a
+ <*> unFinalizeSharing b
+ <*> unFinalizeSharing c
+ <*> unFinalizeSharing d
+instance
+ ( Referenceable letName sem
, Eq letName
, Hashable letName
, Show letName
- ) => Referenceable letName (SharingFinalizer letName repr) where
+ ) =>
+ Referenceable letName (SharingFinalizer letName sem)
+ where
ref isRec = liftDerived . ref isRec
instance
- ( Referenceable letName repr
+ ( Referenceable letName sem
, Eq letName
, Hashable letName
, Show letName
- ) => Definable letName (SharingFinalizer letName repr) where
+ ) =>
+ Definable letName (SharingFinalizer letName sem)
+ where
define name body = SharingFinalizer $ do
refs <- MT.ask
- let (repr, defs) =
+ let (sem, defs) =
MT.runWriter $ MT.runReaderT (unFinalizeSharing body) refs
if name `HS.member` refs
then do
-- to put it in scope even when some 'ref' to it exists outside of 'body'
-- (which can happen when a body-expression is shared),
-- and replace it by a 'ref'.
- MT.lift $ MT.tell $ HM.insert name (SomeLet repr) defs
+ MT.lift $ MT.tell $ HM.insert name (SomeLet sem) defs
return $ ref False name
- else
- -- Remove this unreferenced 'define' node.
+ else -- Remove this unreferenced 'define' node.
unFinalizeSharing body
-- * Class 'Letsable'
-class Letsable letName repr where
+class Letsable letName sem where
-- | @('lets' defs x)@ let-binds @(defs)@ in @(x)@.
- lets :: LetBindings letName repr -> repr a -> repr a
+ lets :: LetBindings letName sem -> sem a -> sem a
lets defs = liftDerived1 (lets ((\(SomeLet val) -> SomeLet (derive val)) <$> defs))
default lets ::
- Derivable repr =>
- FromDerived1 (Letsable letName) repr =>
- LetBindings letName repr -> repr a -> repr a
+ Derivable sem =>
+ FromDerived1 (Letsable letName) sem =>
+ LetBindings letName sem ->
+ sem a ->
+ sem a
-- ** Type 'SomeLet'
-data SomeLet repr = forall a. SomeLet (repr a)
+data SomeLet sem = forall a. SomeLet (sem a)
-- ** Type 'LetBindings'
-type LetBindings letName repr = HM.HashMap letName (SomeLet repr)
+type LetBindings letName sem = HM.HashMap letName (SomeLet sem)
{-
-- | Not used but can be written nonetheless.
instance
- ( Letsable letName repr
+ ( Letsable letName sem
, Eq letName
, Hashable letName
, Show letName
- ) => Letsable letName (SharingFinalizer letName repr) where
+ ) => Letsable letName (SharingFinalizer letName sem) where
lets defs x = SharingFinalizer $ do
ds <- traverse (\(SomeLet v) -> do
r <- unFinalizeSharing v
-}
-- ** Type 'OpenRecs'
+
-- | Mutually recursive terms, in open recursion style.
type OpenRecs letName a = LetRecs letName (OpenRec letName a)
+
-- | Mutually recursive term, in open recursion style.
-- The term is given a @final@ (aka. @self@) map
-- of other terms it can refer to (including itself).
type OpenRec letName a = LetRecs letName a -> a
+
-- | Recursive let bindings.
type LetRecs letName = HM.HashMap letName
--
-- Here all mutually dependent functions are restricted to the same polymorphic type @(a)@.
-- See http://okmij.org/ftp/Computation/fixed-point-combinators.html#Poly-variadic
-mutualFix :: forall recs a. Functor recs => recs ({-finals-}recs a -> a) -> recs a
+mutualFix :: forall recs a. Functor recs => recs ({-finals-} recs a -> a) -> recs a
mutualFix opens = fix f
where
- f :: recs a -> recs a
- f recs = ($ recs) <$> opens
+ f :: recs a -> recs a
+ f recs = ($ recs) <$> opens
sourcephile / git / haskell / symantic-base.git / blobdiff