diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2022, Oleg Grenrus + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Oleg Grenrus nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"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 COPYRIGHT +OWNER 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. diff --git a/ghc-symbol.cabal b/ghc-symbol.cabal new file mode 100644 --- /dev/null +++ b/ghc-symbol.cabal @@ -0,0 +1,40 @@ +cabal-version: 2.4 +name: ghc-symbol +version: 0 +category: Data +synopsis: Symbol on term level +description: + This package fleshes out @Symbol@ on term level, + so we can use the same type for terms and promoted to type level. + +author: Oleg Grenrus +maintainer: Oleg Grenrus +license: BSD-3-Clause +license-file: LICENSE +tested-with: GHC ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.2 + +library + default-language: Haskell2010 + build-depends: + , base >=4.14.0.0 && <4.18 + , binary ^>=0.8.8.0 + , deepseq ^>=1.4.4.0 + , template-haskell >=2.16 && <2.20 + + exposed-modules: GHC.Symbol + hs-source-dirs: src + ghc-options: -Wall + x-docspec-extra-packages: text + +test-suite ghc-symbol-tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: tests + main-is: ghc-symbol-tests.hs + build-depends: + , base + , ghc-symbol + , tasty ^>=1.4.2.3 + , tasty-hunit ^>=0.10.0.3 + , text diff --git a/src/GHC/Symbol.hs b/src/GHC/Symbol.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Symbol.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} +-- | A (slightly unsafe) term level implementation for 'Symbol'. +-- +-- As 'Symbol' in @base@ doesn't have any term-level operations, +-- it's sometimes necessary to have two copies of the same data, +-- the first one using 'String' on term level and +-- second one using 'Symbol' to be promtoed to type level. +-- +-- In GHC-9.2 the similar problem was fixed for @Nat@ and @Natural@, +-- which were distinct types (kinds) before that. +-- +-- As 'String' is a list of 'Char's, we cannot make @type 'Symbol' = 'String'@, +-- but we could do @newtype 'Symbol' = MkSymbol 'String'@. +-- This module /fakes/ that by using 'unsafeCoerce' under the hood. +-- +-- Fleshing out 'Symbol' on term level is suggested in +-- https://gitlab.haskell.org/ghc/ghc/-/issues/10776#note_109601 +-- in 2015. +-- +-- This implementation is slightly unsafe, as currently 'Symbol' is defined +-- as empty data type: +-- +-- @ +-- data 'Symbol' +-- @ +-- +-- This means that you can write +-- +-- @ +-- dangerous :: Symbol -> Int +-- dangerous x = case x of +-- @ +-- +-- and because GHC sees through everything, and knows that 'Symbol' is empty, +-- the above compiles without a warning. +-- +-- If 'Symbol' was defined as @newtype Symbol = Symbol Any@, the +-- above problem would go away, and also implementation of this +-- module would be safer, as 'unsafeCoerce'ing from lifted type to 'Any' +-- and back is guaranteed to work. +-- +-- Of course life would be easier if we just had +-- +-- @ +-- newtype 'Symbol' = MkSymbol 'String' +-- @ +-- +-- but until that is done, you may find this module useful. +-- +-- /Note:/ 'Symbol' is not @Text@. @Text@ has an invariant: it represents /valid/ Unicode text. +-- 'Symbol' is just a list of characters (= Unicode codepoints), like 'String'. +-- E.g. +-- +-- >>> "\55555" :: String +-- "\55555" +-- +-- >>> "\55555" :: Symbol +-- "\55555" +-- +-- but @text@ replaces surrogate codepoints: +-- +-- >>> "\55555" :: Text +-- "\65533" +-- +-- 'Symbol' could use some packed representation of list of characters, +-- if also 'KnownSymbol' would use it as well. Currently +-- 'KnownSymbol' dictionary carries a 'String', so having +-- 'Symbol' be a 'String' is justified'. +-- +module GHC.Symbol ( + -- * Symbol type + Symbol, + symbolToString, + consSymbol, + unconsSymbol, + -- * Type level + KnownSymbol, + symbolVal, + symbolVal', + AppendSymbol, + CmpSymbol, + someSymbolVal, + SomeSymbol (..), + sameSymbol, +) where + +import Control.DeepSeq (NFData (..)) +import Data.Binary (Binary (..)) +import Data.String (IsString (..)) +import GHC.Exts (IsList (..), Proxy#) +import GHC.TypeLits + (AppendSymbol, CmpSymbol, KnownSymbol, SomeSymbol, Symbol, sameSymbol) +import Language.Haskell.TH.Syntax (Lift (..)) +import Text.Printf (PrintfArg (..)) +import Unsafe.Coerce (unsafeCoerce) + +import qualified GHC.TypeLits as GHC + +-- $setup +-- >>> :set -XOverloadedStrings -XTypeApplications -XDataKinds +-- >>> import Data.Text (Text) +-- >>> import Data.Proxy (Proxy (..)) + +------------------------------------------------------------------------------- +-- Conversions +------------------------------------------------------------------------------- + +symbolToString :: Symbol -> String +symbolToString = unsafeCoerce @Symbol @String + +symbolFromString :: String -> Symbol +symbolFromString = unsafeCoerce @String @Symbol + +------------------------------------------------------------------------------- +-- Public interface +------------------------------------------------------------------------------- + +-- this is not exported though, use mempty or "". +emptySymbol :: Symbol +emptySymbol = symbolFromString "" + +-- | Prepend a character to a 'Symbol' +-- +-- >>> consSymbol 'a' "cute" +-- "acute" +-- +consSymbol :: Char -> Symbol -> Symbol +consSymbol c s = symbolFromString (c : symbolToString s) + +-- | Inverse of 'consSymbol' +-- +-- >>> unconsSymbol "" +-- Nothing +-- +-- >>> unconsSymbol "mother" +-- Just ('m',"other") +-- +unconsSymbol :: Symbol -> Maybe (Char, Symbol) +unconsSymbol s = case symbolToString s of + [] -> Nothing + c:s' -> Just (c, symbolFromString s') + +-- instances + +-- | +-- +-- >>> "foo" :: Symbol +-- "foo" +-- +instance Show Symbol where + showsPrec d s = showsPrec d (symbolToString s) + +instance Read Symbol where + readsPrec d s = [ (symbolFromString x, s') | ~(x, s') <- readsPrec d s ] + +instance Eq Symbol where + x == y = symbolToString x == symbolToString y + +instance Ord Symbol where + compare x y = compare (symbolToString x) (symbolToString y) + +-- | +-- +-- >>> "foo" :: Symbol +-- "foo" +-- +instance IsString Symbol where + fromString = symbolFromString + +instance Semigroup Symbol where + x <> y = symbolFromString (symbolToString x ++ symbolToString y) + +instance Monoid Symbol where + mempty = emptySymbol + mappend = (<>) + +instance NFData Symbol where + rnf s = rnf (symbolToString s) + +instance Binary Symbol where + get = fmap symbolFromString get + put s = put (symbolToString s) + +instance Lift Symbol where + liftTyped s = [|| symbolFromString s' ||] where s' = symbolToString s + +instance PrintfArg Symbol where + formatArg s = formatArg (symbolToString s) + +instance IsList Symbol where + type Item Symbol = Char + fromList = symbolFromString + toList = symbolToString + +------------------------------------------------------------------------------- +-- TypeLits +------------------------------------------------------------------------------- + +-- | +-- +-- >>> symbolVal (Proxy @"foobar") +-- "foobar" +-- +symbolVal :: forall n proxy. KnownSymbol n => proxy n -> Symbol +symbolVal p = symbolFromString (GHC.symbolVal p) + +symbolVal' :: forall n. KnownSymbol n => Proxy# n -> Symbol +symbolVal' p = symbolFromString (GHC.symbolVal' p) + +-- | +-- +-- >>> someSymbolVal "foobar" +-- "foobar" +-- +someSymbolVal :: Symbol -> SomeSymbol +someSymbolVal s = GHC.someSymbolVal (symbolToString s) diff --git a/tests/ghc-symbol-tests.hs b/tests/ghc-symbol-tests.hs new file mode 100644 --- /dev/null +++ b/tests/ghc-symbol-tests.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +module Main (main) where + +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.HUnit + +import Data.Proxy (Proxy (..)) +import GHC.Symbol + +main :: IO () +main = defaultMain $ testGroup "ghc-symbol" + [ testCase "Eq" $ do + assertBool "same" $ symbolVal (Proxy @"foo") == symbolVal (Proxy @"foo") + assertBool "not" $ symbolVal (Proxy @"foo") /= symbolVal (Proxy @"bar") + + -- this is interesting :) + , testCaseSteps "dangerous" $ \info -> do + info $ dangerous "foo" + + ] + +dangerous :: Symbol -> String +dangerous x = case x of