packages feed

ghc-symbol (empty) → 0

raw patch · 4 files changed

+319/−0 lines, 4 filesdep +basedep +binarydep +deepseq

Dependencies added: base, binary, deepseq, ghc-symbol, tasty, tasty-hunit, template-haskell, text

Files

+ LICENSE view
@@ -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.
+ ghc-symbol.cabal view
@@ -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 <oleg.grenrus@iki.fi>+maintainer:    Oleg Grenrus <oleg.grenrus@iki.fi>+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
+ src/GHC/Symbol.hs view
@@ -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)
+ tests/ghc-symbol-tests.hs view
@@ -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