packages feed

intern (empty) → 0.1

raw patch · 6 files changed

+252/−0 lines, 6 filesdep +basedep +bytestringdep +hashablesetup-changed

Dependencies added: base, bytestring, hashable, unordered-containers

Files

+ Data/ByteString/Interned.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE TypeFamilies, FlexibleInstances #-}+module Data.ByteString.Interned+  ( InternedByteString+  ) where++import Data.String+import Data.Interned+import Data.ByteString+import Data.ByteString.Char8 as Char8+import Data.Hashable+import Data.Function (on)++data InternedByteString = IBS +  {-# UNPACK #-} !(Id InternedByteString)+  {-# UNPACK #-} !ByteString++instance IsString InternedByteString where+  fromString = intern . Char8.pack++instance Eq InternedByteString where+  (==) = (==) `on` identity++instance Ord InternedByteString where+  compare = compare `on` identity++instance Show InternedByteString where+  showsPrec d (IBS _ b) = showsPrec d b++instance Interned InternedByteString where+  type Uninterned InternedByteString = ByteString+  data Description InternedByteString = DBS {-# UNPACK #-} !ByteString+    deriving (Eq) +  describe = DBS+  unintern (IBS _ b) = b +  identify = IBS+  identity (IBS i _) = i+  cache = ibsCache++instance Hashable (Description InternedByteString) where+  hash (DBS h) = hash h++ibsCache :: Cache InternedByteString+ibsCache = mkCache+{-# NOINLINE ibsCache #-}
+ Data/Interned.hs view
@@ -0,0 +1,9 @@+module Data.Interned+  ( Interned(..)+  , mkCache+  , Cache+  , Id(..)+  , intern+  ) where++import Data.Interned.Internal
+ Data/Interned/Internal.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE TypeFamilies+           , FlexibleInstances+           , FlexibleContexts+           , GeneralizedNewtypeDeriving #-}+module Data.Interned.Internal+  ( Interned(..)+  , mkCache+  , Cache(..)+  , CacheState(..)+  , Id(..)+  , intern+  ) where++import Data.Hashable+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Control.Concurrent.MVar+import GHC.IO (unsafeDupablePerformIO, unsafePerformIO)+import System.Mem.Weak++data CacheState t = CacheState {-# UNPACK #-} !(Id t) (HashMap (Description t) (Weak t))++newtype Cache t = Cache { getCache :: MVar (CacheState t) }++mkCache :: Cache t+mkCache = Cache $ unsafePerformIO $ newMVar $ CacheState 0 HashMap.empty++newtype Id t = Id Int deriving (Eq,Ord,Show,Num,Real,Integral,Enum)++instance Hashable (Id t) where+  hash (Id t) = hash t+  hashWithSalt s (Id t) = hashWithSalt s t++class ( Eq (Description t)+      , Hashable (Description t)+      ) => Interned t where+  data Description t+  type Uninterned t+  describe :: Uninterned t -> Description t +  unintern :: t -> Uninterned t+  identify :: Id t -> Uninterned t -> t+  identity :: t -> Id t+  cache    :: Cache t++intern :: Interned t => Uninterned t -> t+intern bt = unsafeDupablePerformIO $ modifyMVar (getCache cache) go +  where+  dt = describe bt+  go (CacheState i m) = case HashMap.lookup dt m of+    Nothing -> k i m+    Just wt -> do+      mt <- deRefWeak wt+      case mt of +        Just t -> return (CacheState i m, t)+        Nothing -> k i m+  k i m = do let t = identify i bt +             wt <- t `seq` mkWeakPtr t $ Just remove+             return (CacheState (i + 1) (HashMap.insert dt wt m), t)+  remove = modifyMVar_ (getCache cache) $ +    \ (CacheState i m) -> return $ CacheState i (HashMap.delete dt m)++{-+type Var = Int++data Term+  = App {-# UNPACK #-} !(Id Term) !Term !Term+  | Lam {-# UNPACK #-} !(Id Term) {-# UNPACK #-} !Var !Term !Term+  | Pi  {-# UNPACK #-} !(Id Term) {-# UNPACK #-} !Var !Term !Term+  | Set {-# UNPACK #-} !(Id Term) {-# UNPACK #-} !Int+  deriving Show+data UninternedTerm +  = BApp Term Term+  | BLam Var Term Term +  | BPi  Var Term Term+  | BSet Int deriving Show+instance Interned Term where+  type Uninterned Term = UninternedTerm+  data Description Term = DApp (Id Term) (Id Term)+                 | DLam Var (Id Term) (Id Term)+                 | DPi  Var (Id Term) (Id Term)+                 | DSet Int deriving Show+  describe (BApp f a)   = DApp (identity f) (identity a) +  describe (BLam v t e) = DLam v (identity t) (identity e)+  describe (BPi v t e)  = DPi v (identity t) (identity e)+  describe (BSet n) = DSet n+  identify i = go where+    go (BApp f a) = App i f a +    go (BLam v t e) = Lam i v t e+    go (BPi v t e) = Pi i v t e+    go (BSet n) = Set i n+  identity (App i _ _) = i+  identity (Lam i _ _ _) = i+  identity (Pi i _ _ _) = i+  identity (Set i _) = i+  unintern (App _ f a) = BApp f a+  unintern (Lam _ v t e) = BLam v t e+  unintern (Pi _ v t e) = BPi v t e+  unintern (Set _ n) = BSet n+  cache = termCache++termCache :: Cache Term+termCache = mkCache+{-# NOINLINE termCache #-}++instance Eq (Description Term) where+  DApp f a     == DApp f' a'    = f == f' && a == a'+  DLam v t e   == DLam v' t' e' = v == v' && t == t' && e == e'+  DPi v t e    == DPi v' t' e'  = v == v' && t == t' && e == e'+  DSet n       == DSet n'       = n == n'+  _            == _             = False++instance Hashable (Description Term) where+  hash (DApp f a)   = 0 `hashWithSalt` f `hashWithSalt` a+  hash (DLam v t e) = 1 `hashWithSalt` v `hashWithSalt` t `hashWithSalt` e+  hash (DPi v t e)  = 2 `hashWithSalt` v `hashWithSalt` t `hashWithSalt` e+  hash (DSet n)     = 3 `hashWithSalt` n++instance Eq Term where+  (==) = (==) `on` identity++instance Ord Term where+  compare = compare `on` identity++app :: Term -> Term -> Term+app a b = intern (BApp a b)++lam :: Var -> Term -> Term -> Term+lam v t e = intern (BLam v t e)++pi :: Var -> Term -> Term -> Term+pi v t e = intern (BPi v t e)++set :: Int -> Term+set i = intern (BSet i)+-}
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright 2011 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ intern.cabal view
@@ -0,0 +1,32 @@+name:          intern+category:      Data, Data Structures+version:       0.1+license:       BSD3+cabal-version: >= 1.6+license-file:  LICENSE+author:        Edward A. Kmett+maintainer:    Edward A. Kmett <ekmett@gmail.com>+stability:     experimental+homepage:      http://github.com/ekmett/intern/+copyright:     Copyright (C) 2011 Edward A. Kmett+synopsis:      Efficient hash-consing for arbitrary data types+description:   Efficient hash-consing for arbitrary data types+build-type:    Simple++source-repository head+  type: git+  location: git://github.com/ekmett/intern.git++library+  build-depends: +    base >= 4 && < 5,+    bytestring >= 0.9.1 && < 0.10,+    unordered-containers >= 0.1.4 && < 0.2,+    hashable >= 1.1.2 && < 1.2++  exposed-modules:+    Data.Interned+    Data.Interned.Internal+    Data.ByteString.Interned++  ghc-options: -Wall