diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,26 @@ +steps: + - simple_align: + cases: always + top_level_patterns: always + records: always + multi_way_if: always + - imports: + align: global + list_align: after_alias + pad_module_names: true + long_list_align: inline + empty_list_align: inherit + list_padding: 4 + separate_lists: true + space_surround: false + post_qualify: false + group_imports: false + - language_pragmas: + style: vertical + align: true + remove_redundant: true + - trailing_whitespace: {} + +columns: 80 +newline: lf +cabal: true diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,15 @@ +# Changelog + +## 0.3.0 + +- Add GHC 9.12 and 9.14 to CI and allow `containers` 0.8. +- Fix generic `Data` operations to reconstruct symbols through `intern`, + preserving the association between identifiers and strings. **Compatibility + change:** the generic representation now has one `String` field instead of + `Int` and `String` fields. Consumers of the old representation must adapt. +- Require `base >= 4.9`, matching the GHC 8.0+ CI matrix, and remove obsolete + compiler compatibility code. +- Add baseline and regression tests, with test execution in CI. +- Move library sources into `src/`, enable library warnings, and configure + Stylish Haskell and VS Code formatting. +- Document ordering, interned-string lifetime, and the generic representation. diff --git a/Data/Symbol.hs b/Data/Symbol.hs deleted file mode 100644 --- a/Data/Symbol.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE Trustworthy #-} - --- | --- Module : Data.Symbol --- Copyright : (c) Harvard University 2009-2011 --- : (c) Geoffrey Mainland 2011-2014 --- License : BSD-style --- Maintainer : Geoffrey Mainland - -module Data.Symbol ( - Symbol, - intern, - unintern - ) where - -import Data.Symbol.Unsafe diff --git a/Data/Symbol/Unsafe.hs b/Data/Symbol/Unsafe.hs deleted file mode 100644 --- a/Data/Symbol/Unsafe.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} - --- | --- Module : Data.Symbol.Unsafe --- Copyright : (c) Harvard University 2009-2011 --- : (c) Geoffrey Mainland 2011-2014 --- License : BSD-style --- Maintainer : Geoffrey Mainland - -module Data.Symbol.Unsafe ( - Symbol(..), - intern, - unintern - ) where - -import Control.Concurrent.MVar -import Control.DeepSeq -import Data.Data (Data) -#if __GLASGOW_HASKELL__ >= 608 -import Data.String -#endif /* __GLASGOW_HASKELL__ >= 608 */ -import Data.Typeable (Typeable) -import qualified Data.Map as Map -import System.IO.Unsafe (unsafePerformIO) - -data Symbol = -- | Unique identifier and the string itself - Symbol {-# UNPACK #-} !Int !String -#if defined(__GLASGOW_HASKELL__) - deriving (Data, Typeable) -#endif /* defined(__GLASGOW_HASKELL__) */ - -instance Eq Symbol where - (Symbol i1 _) == (Symbol i2 _) = i1 == i2 - -instance Ord Symbol where - compare (Symbol i1 _) (Symbol i2 _) = compare i1 i2 - -instance Show Symbol where - showsPrec d (Symbol _ s) = showsPrec d s - -instance Read Symbol where - readsPrec d t = [(intern s, t') | (s, t') <- readList t] - -#if __GLASGOW_HASKELL__ >= 608 -instance IsString Symbol where - fromString = intern -#endif /* __GLASGOW_HASKELL__ >= 608 */ - -data SymbolEnv = SymbolEnv - { uniq :: {-# UNPACK #-} !Int - , symbols :: !(Map.Map String Symbol) - } - -symbolEnv :: MVar SymbolEnv -{-# NOINLINE symbolEnv #-} -symbolEnv = unsafePerformIO $ newMVar $ SymbolEnv 1 Map.empty - --- We @'deepseq' s@ so that we can guarantee that when we perform the lookup we --- won't potentially have to evaluate a thunk that might itself call @'intern'@, --- leading to a deadlock. - --- |Intern a string to produce a 'Symbol'. -intern :: String -> Symbol -{-# NOINLINE intern #-} -intern s = s `deepseq` unsafePerformIO $ modifyMVar symbolEnv $ \env -> do - case Map.lookup s (symbols env) of - Nothing -> do let sym = Symbol (uniq env) s - let env' = env { uniq = uniq env + 1, - symbols = Map.insert s sym - (symbols env) - } - env' `seq` return (env', sym) - Just sym -> return (env, sym) - --- |Return the 'String' associated with a 'Symbol'. -unintern :: Symbol -> String -unintern (Symbol _ s) = s diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,48 @@ +# The `symbol` Package [![Hackage](https://img.shields.io/hackage/v/symbol.svg)](https://hackage.haskell.org/package/symbol) [![Actions Status: haskell-ci](https://github.com/mainland/symbol/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/mainland/symbol/actions?query=workflow%3Ahaskell-ci) + +Provides a `Symbol` data type allowing fast symbol comparisons and functions for interning symbols and recovering their `String` representation. + +```haskell +import Data.Symbol (intern, unintern) + +intern "name" == intern "name" -- True +unintern (intern "name") -- "name" +``` + +Symbols created through `intern` compare equal exactly when their strings do. +Equality and ordering compare integer identifiers in constant time. Ordering +follows identifier allocation, rather than lexicographic string order, and can +vary with evaluation order and between runs. For lexicographic ordering, compare +the strings returned by `unintern`. + +Interning uses a synchronized, process-wide table. Every distinct interned +string and its symbol remain in that table for the lifetime of the process, even +after the caller drops all references. Memory use therefore grows with the +number and total size of distinct strings interned. `intern` fully evaluates its +input string before accessing the table. Inputs must be finite and fully +defined. + +The `Data` instance exposes a `Symbol` constructor with one `String` field. +Generic construction and transformations call `intern`, preserving symbol +identity. Use `Data.Symbol` for the abstract API. `Data.Symbol.Unsafe` exposes +the raw constructor, which can break the association between identifiers and +strings. + +To build and run the test suite: + +```sh +cabal build all +cabal test all --test-show-details=direct +``` + +The package supports GHC 8.0 and later. CI tests the versions listed in +`symbol.cabal`; regenerate the workflow with `haskell-ci regenerate` after +changing that list or the package components. + +Formatting uses `.stylish-haskell.yaml`. With the VS Code Haskell extension and +a working Haskell Language Server, the workspace settings enable formatting on +save. To format from the command line: + +```sh +stylish-haskell -i Setup.hs src/Data/Symbol.hs src/Data/Symbol/Unsafe.hs tests/Main.hs +``` diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,3 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/src/Data/Symbol.hs b/src/Data/Symbol.hs new file mode 100644 --- /dev/null +++ b/src/Data/Symbol.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Data.Symbol +-- Copyright : (c) Harvard University 2009-2011 +-- : (c) Geoffrey Mainland 2011-2014 +-- License : BSD-style +-- Maintainer : Geoffrey Mainland +-- +-- Interned strings with constant-time equality and ordering. Ordering compares +-- allocated identifiers and can vary with evaluation order and between runs. +-- For lexicographic ordering, compare the strings returned by 'unintern'. +-- +-- Every distinct interned string and its symbol remain in the global table for +-- the lifetime of the process, even when callers no longer reference them. +-- +-- The @Data@ instance represents a symbol as a @Symbol@ constructor with a +-- single 'String' field. Generic construction and transformations use 'intern' +-- to preserve symbol identity. The internal identifier is not exposed. + +module Data.Symbol ( + Symbol, + intern, + unintern + ) where + +import Data.Symbol.Unsafe diff --git a/src/Data/Symbol/Unsafe.hs b/src/Data/Symbol/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Symbol/Unsafe.hs @@ -0,0 +1,97 @@ +-- | +-- Module : Data.Symbol.Unsafe +-- Copyright : (c) Harvard University 2009-2011 +-- : (c) Geoffrey Mainland 2011-2014 +-- License : BSD-style +-- Maintainer : Geoffrey Mainland +-- +-- This module exposes the raw symbol constructor. Constructing symbols directly +-- can break the association between identifiers and strings. Prefer the abstract +-- API in "Data.Symbol" and construct symbols with 'intern'. + +module Data.Symbol.Unsafe ( + Symbol(..), + intern, + unintern + ) where + +import Control.Concurrent.MVar +import Control.DeepSeq +import Data.Data (Constr, Data (..), DataType, + Fixity (Prefix), constrIndex, + mkConstr, mkDataType) +import qualified Data.Map as Map +import Data.String +import System.IO.Unsafe (unsafePerformIO) + +-- | An interned string. Equality and ordering compare allocated identifiers in +-- constant time. Ordering can vary with evaluation order and between runs; +-- compare the results of 'unintern' for lexicographic ordering. +data Symbol = -- | Unique identifier and the string itself + Symbol {-# UNPACK #-} !Int !String + +-- | Generic operations expose only the string and reconstruct through 'intern' +-- to preserve the association between the string and its unique identifier. +instance Data Symbol where + gfoldl k z sym = z intern `k` unintern sym + gunfold k z c + | constrIndex c == 1 = k (z intern) + | otherwise = error "Data.Symbol.Unsafe.gunfold: invalid constructor" + toConstr _ = symbolConstr + dataTypeOf _ = symbolDataType + +symbolDataType :: DataType +symbolDataType = mkDataType "Data.Symbol.Unsafe.Symbol" [symbolConstr] + +symbolConstr :: Constr +symbolConstr = mkConstr symbolDataType "Symbol" [] Prefix + +instance Eq Symbol where + (Symbol i1 _) == (Symbol i2 _) = i1 == i2 + +instance Ord Symbol where + compare (Symbol i1 _) (Symbol i2 _) = compare i1 i2 + +instance Show Symbol where + showsPrec d (Symbol _ s) = showsPrec d s + +instance Read Symbol where + readsPrec _ t = [(intern s, t') | (s, t') <- readList t] + +instance IsString Symbol where + fromString = intern + +data SymbolEnv = SymbolEnv + { uniq :: {-# UNPACK #-} !Int + , symbols :: !(Map.Map String Symbol) + } + +symbolEnv :: MVar SymbolEnv +{-# NOINLINE symbolEnv #-} +symbolEnv = unsafePerformIO $ newMVar $ SymbolEnv 1 Map.empty + +-- We @'deepseq' s@ so that we can guarantee that when we perform the lookup we +-- won't potentially have to evaluate a thunk that might itself call @'intern'@, +-- leading to a deadlock. + +-- | Intern a string using the synchronized global symbol table. Equal strings +-- produce equal symbols. The input is fully evaluated before accessing the +-- table, so it must be finite and fully defined. +-- +-- Every distinct interned string and its symbol remain in the table for the +-- lifetime of the process, even after callers drop all references. +intern :: String -> Symbol +{-# NOINLINE intern #-} +intern s = s `deepseq` unsafePerformIO $ modifyMVar symbolEnv $ \env -> do + case Map.lookup s (symbols env) of + Nothing -> do let sym = Symbol (uniq env) s + let env' = env { uniq = uniq env + 1, + symbols = Map.insert s sym + (symbols env) + } + env' `seq` return (env', sym) + Just sym -> return (env, sym) + +-- | Return the string associated with a symbol. +unintern :: Symbol -> String +unintern (Symbol _ s) = s diff --git a/symbol.cabal b/symbol.cabal --- a/symbol.cabal +++ b/symbol.cabal @@ -1,10 +1,10 @@ name: symbol -version: 0.2.4.1 +version: 0.3.0 cabal-version: >= 1.10 license: BSD3 license-file: LICENSE copyright: (c) 2006-2011 Harvard University - (c) 2011-2024 Geoffrey Mainland + (c) 2011-2026 Geoffrey Mainland author: Geoffrey Mainland maintainer: Geoffrey Mainland stability: alpha @@ -25,22 +25,47 @@ GHC==9.4.8, GHC==9.6.4, GHC==9.8.2, - GHC==9.10.1 + GHC==9.10.1, + GHC==9.12.4, + GHC==9.14.1 build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + .stylish-haskell.yaml + library + hs-source-dirs: src + exposed-modules: Data.Symbol Data.Symbol.Unsafe build-depends: - base >= 4 && < 5, - containers >= 0.2 && < 0.8, - deepseq >= 1.0 && < 2.0 + base >= 4.9 && < 5, + containers >= 0.2 && < 0.9, + deepseq >= 1.0 && < 2 default-language: Haskell2010 + ghc-options: -Wall +test-suite symbol-tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + + build-depends: + base >= 4.9 && < 5, + symbol, + tasty >= 1.4 && < 1.6, + tasty-hunit >= 0.10 && < 0.11, + tasty-quickcheck >= 0.10 && < 0.12 + + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N2 + source-repository head type: git - location: git://github.com/mainland/symbol.git + location: https://github.com/mainland/symbol.git diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,149 @@ +module Main (main) where + +import Control.Concurrent (forkFinally, killThread, newEmptyMVar, + putMVar, readMVar, takeMVar) +import Control.Exception (ErrorCall, evaluate, finally, throwIO, + try) +import Control.Monad (forM, forM_) +import Data.Data (Data, fromConstrB, gmapM, gmapT, + toConstr) +import Data.Maybe (fromMaybe) +import Data.String (fromString) +import Data.Symbol (Symbol, intern, unintern) +import Data.Typeable (Typeable, cast) +import Test.Tasty (TestTree, defaultMain, localOption, + mkTimeout, testGroup) +import Test.Tasty.HUnit (Assertion, assertFailure, testCase, + (@?=)) +import Test.Tasty.QuickCheck (UnicodeString (..), testProperty) +import Text.Read (readMaybe) + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "symbol" + [ testGroup "interning" + [ testProperty "preserves strings" $ \(UnicodeString s) -> + unintern (intern s) == s + , testProperty "equality agrees with string equality" $ + \(UnicodeString s) (UnicodeString t) -> + (intern s == intern t) == (s == t) + , testProperty "repeated interning preserves identity" $ \(UnicodeString s) -> + intern s == intern (reverse (reverse s)) + , testProperty "IsString agrees with intern" $ \(UnicodeString s) -> + fromString s == intern s + ] + , testGroup "ordering laws" + [ testProperty "compare agrees with equality" $ + \(UnicodeString s) (UnicodeString t) -> + (compare (intern s) (intern t) == EQ) == (s == t) + , testProperty "comparison is antisymmetric" $ + \(UnicodeString s) (UnicodeString t) -> + compare (intern s) (intern t) == invert (compare (intern t) (intern s)) + , testProperty "ordering is transitive" $ + \(UnicodeString s) (UnicodeString t) (UnicodeString u) -> + let x = intern s + y = intern t + z = intern u + in not (x <= y && y <= z) || x <= z + ] + , testGroup "Read and Show" + [ testProperty "Show agrees with String" $ \(UnicodeString s) -> + show (intern s) == show s + , testProperty "symbols round-trip" $ \(UnicodeString s) -> + readMaybe (show (intern s)) == Just (intern s) + , testProperty "lists of symbols round-trip" $ \strings -> + let symbols = map (intern . getUnicodeString) strings + in readMaybe (show symbols) == Just symbols + , testGroup "edge cases" + [ testCase (show s) $ do + unintern (intern s) @?= s + readMaybe (show (intern s)) @?= Just (intern s) + | s <- ["", "\NUL", "\n\t", "quote\"slash\\", "\x3bb\x1f600"] + ] + , testCase "reads parenthesized strings" $ + readMaybe "((\"alpha\"))" @?= Just (intern "alpha") + , testCase "reads character lists" $ + readMaybe "['a', 'b']" @?= Just (intern "ab") + , testCase "leaves trailing input" $ + reads "\"alpha\" rest" @?= [(intern "alpha", " rest")] + , testCase "rejects malformed input" $ + (readMaybe "\"unterminated" :: Maybe Symbol) @?= Nothing + ] + , testGroup "Data instance" + [ testCase "generic string updates preserve interning" $ do + let original = intern "generic:original" + expected = intern "generic:changed" + changed = gmapT (replace ("generic:changed" :: String)) original + unintern changed @?= "generic:changed" + changed @?= expected + (changed == original) @?= False + compare changed expected @?= EQ + , testCase "generic integer updates cannot forge identifiers" $ do + let original = intern "generic:original" + changed = gmapT (replace (0 :: Int)) original + changed @?= original + unintern changed @?= unintern original + , testProperty "generic identity traversal preserves symbols" $ + \(UnicodeString s) -> + let sym = gmapT id (intern s) + in sym == intern s && unintern sym == s + , testCase "monadic generic updates preserve interning" $ do + changed <- gmapM (return . replace ("generic:changed" :: String)) + (intern "generic:original") + changed @?= intern "generic:changed" + unintern changed @?= "generic:changed" + , testCase "generic construction interns its argument" $ do + let rebuilt = fromConstrB (stringField "generic:rebuilt") + (toConstr (intern "generic:original")) :: Symbol + rebuilt @?= intern "generic:rebuilt" + unintern rebuilt @?= "generic:rebuilt" + ] + , localOption (mkTimeout 10000000) $ testGroup "evaluation and concurrency" + [ testCase "nested interning does not deadlock" $ do + sym <- evaluate (intern ("outer:" ++ unintern (intern "inner"))) + unintern sym @?= "outer:inner" + , testCase "input exceptions leave the table usable" $ do + result <- try (evaluate (intern ('x' : error "bad input"))) + :: IO (Either ErrorCall Symbol) + case result of + Left _ -> return () + Right _ -> assertFailure "intern did not evaluate the entire input" + sym <- evaluate (intern "after-exception") + unintern sym @?= "after-exception" + , testCase "concurrent interning preserves identity" concurrentInterning + ] + ] + +replace :: (Typeable a, Typeable b) => a -> b -> b +replace replacement value = fromMaybe value (cast replacement) + +stringField :: Data a => String -> a +stringField value = fromMaybe (error "Unexpected non-string Symbol field") (cast value) + +invert :: Ordering -> Ordering +invert LT = GT +invert EQ = EQ +invert GT = LT + +concurrentInterning :: Assertion +concurrentInterning = do + gate <- newEmptyMVar + workers <- forM [0 .. 7 :: Int] $ \offset -> do + done <- newEmptyMVar + tid <- forkFinally + (do readMVar gate + forM [0 .. 255 :: Int] $ \i -> do + let s = "concurrent:" ++ show ((i + offset) `mod` 128) + sym <- evaluate (intern s) + return (s, sym)) + (putMVar done) + return (tid, done) + flip finally (mapM_ (killThread . fst) workers) $ do + putMVar gate () + results <- mapM (takeMVar . snd) workers + symbols <- mapM (either throwIO return) results + forM_ (concat symbols) $ \(s, sym) -> do + unintern sym @?= s + sym @?= intern s